├── .github
└── FUNDING.yml
├── .gitignore
├── .travis.yml
├── CHANGELOG.md
├── LICENSE.txt
├── README.md
├── cli
├── ravk.rkt
├── ravk_generate.rkt
├── ravk_show.rkt
├── ravk_show_spec.rkt
└── shared.rkt
├── examples
├── mandelbrot
│ ├── .gitignore
│ ├── README.md
│ ├── bindings-raw.rkt
│ ├── bindings.rkt
│ ├── comp.spv
│ ├── mandelbrot-raw.rkt
│ └── mandelbrot.rkt
├── minimal.rkt
└── physical-device-report.rkt
├── info.rkt
├── main.rkt
├── pre-commit
├── private
├── assets
│ ├── hero.png
│ ├── hero.xcf
│ └── vk.xml
├── c.rkt
├── generate
│ ├── api-constants.rkt
│ ├── api-constants.test.rkt
│ ├── ctypes.rkt
│ ├── ctypes.test.rkt
│ ├── defines.rkt
│ ├── defines.test.rkt
│ ├── handles.rkt
│ ├── handles.test.rkt
│ ├── interdependent.rkt
│ ├── interdependent.test.rkt
│ ├── make-unsafe.rkt
│ ├── preamble.rkt
│ ├── shared.rkt
│ ├── typedefs.rkt
│ ├── typedefs.test.rkt
│ └── vkresult-checker.rkt
├── memos.rkt
├── paths.rkt
├── txexpr.rkt
├── unsafe-preamble.rkt
└── writer.rkt
├── scribblings
├── maintainers.scrbl
├── ravk.scrbl
├── setup.scrbl
├── spec.scrbl
├── unsafe.scrbl
└── vulkan.scrbl
├── spec.rkt
└── unsafe.rkt
/.github/FUNDING.yml:
--------------------------------------------------------------------------------
1 | github: zyrolasting
2 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | \#*
3 | .\#*
4 | .DS_Store
5 | compiled/
6 | /doc/
7 | *.zo
8 | *.dep
9 |
10 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: c
2 |
3 | # Based from: https://github.com/greghendershott/travis-racket
4 |
5 | # Optional: Remove to use Travis CI's older infrastructure.
6 | sudo: false
7 |
8 | env:
9 | global:
10 | # Supply a global RACKET_DIR environment variable. This is where
11 | # Racket will be installed. A good idea is to use ~/racket because
12 | # that doesn't require sudo to install and is therefore compatible
13 | # with Travis CI's newer container infrastructure.
14 | - RACKET_DIR=~/racket
15 | matrix:
16 | # Supply at least one RACKET_VERSION environment variable. This is
17 | # used by the install-racket.sh script (run at before_install,
18 | # below) to select the version of Racket to download and install.
19 | #
20 | # Supply more than one RACKET_VERSION (as in the example below) to
21 | # create a Travis-CI build matrix to test against multiple Racket
22 | # versions.
23 | - RACKET_VERSION=6.0
24 | - RACKET_VERSION=6.5
25 | - RACKET_VERSION=6.11
26 | - RACKET_VERSION=HEAD
27 |
28 | matrix:
29 | allow_failures:
30 | # - env: RACKET_VERSION=HEAD
31 | fast_finish: true
32 |
33 | before_install:
34 | - git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket
35 | - cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh!
36 | - export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us
37 |
38 | install:
39 | - raco pkg install --deps search-auto
40 |
41 | before_script:
42 |
43 | # Here supply steps such as raco make, raco test, etc. You can run
44 | # `raco pkg install --deps search-auto` to install any required
45 | # packages without it getting stuck on a confirmation prompt.
46 | script:
47 | - raco test -x -p vulkan
48 |
49 | after_success:
50 | - raco setup --check-pkg-deps --pkgs vulkan
51 | - raco pkg install --deps search-auto cover cover-coveralls
52 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage .
53 |
--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Changelog
2 |
3 | This file summarizes changes to the project over time.
4 |
5 | The format is based on [Keep a
6 | Changelog](https://keepachangelog.com/en/1.0.0/).
7 |
8 | Each version is in the format `major.minor`. `minor` and `major`
9 | increments are subject to the author's interpretation of the words,
10 | but generally mean that `major` changes have "bigger" impact than
11 | `minor` changes. That said, _breaking changes have no relationship to
12 | version numbers._ By policy, any breaking change is simply avoided
13 | unless there's a good reason to introduce one. It's [too difficult to
14 | draw a reliable numerical relationship][jash], since some breaking
15 | changes are meant to prepare intended functionality. You should not
16 | upgrade until you have reason or desire to do so. If you are starting
17 | out with this project, then you should use the latest version.
18 |
19 | ## [Unreleased]
20 | Nothing yet.
21 |
22 | ## [1.2] - 2020-03-23
23 | * Synchronized implementation to v1.2 specification
24 | * Patch bug where generated union declarations have `void` members.
25 |
26 | ## [1.1] - 2019-11-12
27 | * Add missing `compatibility-lib` declaration
28 |
29 | ## [1.0] - 2019-11-15
30 | * Add `ravk` CLI
31 | * Refactor to use distributed code generators
32 | * Reorganize modules
33 | * Publish `vulkan/spec`, and `vulkan/unsafe`
34 | * Add example applications
35 |
36 | ## [0.0] - 2019-08-24
37 | * Start Racket package
38 | * Add simple model for working with `vk.xml`
39 | * Work on monolithic code generator
40 | * Add tiny examples
41 |
42 | [Unreleased]: https://github.com/zyrolasting/racket-vulkan/compare/v1.2...HEAD
43 | [1.2]: https://github.com/zyrolasting/racket-vulkan/compare/v1.1...v1.2
44 | [1.1]: https://github.com/zyrolasting/racket-vulkan/compare/v1.0...v1.1
45 | [1.0]: https://github.com/zyrolasting/racket-vulkan/compare/v0.0...v1.0
46 | [0.0]: https://github.com/zyrolasting/racket-vulkan/releases/tag/v0.0
47 |
48 | [jash]: https://gist.github.com/jashkenas/cbd2b088e20279ae2c8e
49 |
--------------------------------------------------------------------------------
/LICENSE.txt:
--------------------------------------------------------------------------------
1 | Copyright 2019 Sage Lennon Gerard
2 |
3 | Permission is hereby granted, free of charge, to any person obtaining a copy of
4 | this software and associated documentation files (the "Software"), to deal in
5 | the Software without restriction, including without limitation the rights to
6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
7 | the Software, and to permit persons to whom the Software is furnished to do so,
8 | subject to the following conditions:
9 |
10 | The above copyright notice and this permission notice shall be included in all
11 | copies or substantial portions of the Software.
12 |
13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
19 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | [](https://sagegerard.com/subscribe.html)
2 | [](https://opensource.org/licenses/MIT)
3 | [](http://docs.racket-lang.org/vulkan/index.html)
4 | [](https://github.com/zyrolasting/racket-vulkan)
5 |
6 |
7 |
8 |
9 |
10 | Vulkan® API integration and utilities for Racket.
11 |
12 | _Vulkan and the Vulkan logo are registered trademarks of the Khronos Group Inc._
13 |
14 | ## What you get
15 | - [x] Faithful replication of the raw Vulkan API
16 | - [x] Opt-in safety and conveniences
17 | - [x] Powerful code generators that target any `vk.xml`
18 | - [x] Vulkan 1.2 support, and the means to adapt to future specs
19 | - [x] All platform bindings exposed
20 |
21 | ## Quick start
22 |
23 | ```console
24 | $ raco pkg install vulkan
25 | $ ravk generate unsafe > unsafe.rkt
26 | ```
27 |
28 | This generates Racket bindings using the local `vk.xml` mirror that
29 | comes with the package. From here, you can `(require "unsafe.rkt")`
30 | and use Vulkan from the dependent module [according to the
31 | manual][unsafe].
32 |
33 | [unsafe]: https://docs.racket-lang.org/vulkan/Unsafe_Bindings.html
34 |
--------------------------------------------------------------------------------
/cli/ravk.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide process-command-line summary)
4 |
5 | (define summary "Controls for Vulkan-Racket projects")
6 |
7 | (module+ main (void (process-command-line)))
8 |
9 | (require racket/cmdline
10 | racket/runtime-path
11 | (only-in mzlib/etc this-expression-file-name)
12 | natural-cli
13 | "./shared.rkt")
14 |
15 | (define program-name (get-program-name (this-expression-file-name)))
16 | (define-runtime-path cli-directory ".")
17 |
18 | (define (process-command-line)
19 | (define-values (finish-expr arg-strings-expr help-expr unknown-expr)
20 | (make-subcommand-handlers cli-directory program-name))
21 | (command-line #:program program-name
22 | #:once-each [("-l" "--latest")
23 | ("Use the latest official vk.xml from the Khronos Group,"
24 | "whenever relevant (Requires network connection).")
25 | (use-latest? #t)]
26 | #:handlers finish-expr arg-strings-expr help-expr unknown-expr))
27 |
--------------------------------------------------------------------------------
/cli/ravk_generate.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide process-command-line summary)
4 |
5 | (define summary "Write code fragment from module to STDOUT.")
6 |
7 | ; Do not change anything below if you only want subcommands.
8 | (require racket/cmdline
9 | (only-in mzlib/etc this-expression-file-name)
10 | natural-cli
11 | "./shared.rkt"
12 | "../private/paths.rkt"
13 | "../private/generate/shared.rkt"
14 | "../private/writer.rkt")
15 |
16 | (define program-name (get-program-name (this-expression-file-name)))
17 |
18 | (define names=>modules
19 | #hash(("unsafe" . "make-unsafe.rkt")))
20 | (define (resolve name)
21 | (if (and (hash-has-key? names=>modules name) (not (file-exists? name)))
22 | (build-path private-path "generate" (hash-ref names=>modules name))
23 | name))
24 |
25 | (define (process-command-line)
26 | (define config (make-hash))
27 | (command-line #:program program-name
28 | #:once-each
29 | [("--enable-auto-check-vkresult" "-r")
30 | ("When set, foreign function wrappers will automatically "
31 | "check VkResult values and raise exceptions for error codes.")
32 | (hash-set! config 'enable-auto-check-vkresult #t)]
33 | [("--enable-symbolic-enums" "-e")
34 | ("When set, C enum types are represented using _enum and _bitmask"
35 | "types in your bindings.")
36 | (hash-set! config 'enable-symbolic-enums #t)]
37 | #:args (path-or-name . others) ; Force at least one
38 | (for ([target (cons path-or-name others)])
39 | (define module-path (resolve target))
40 | (write-generated module-path config))))
41 |
--------------------------------------------------------------------------------
/cli/ravk_show.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide process-command-line summary)
4 |
5 | (define summary "Review key information")
6 |
7 | ; Remove to prevent direct execution.
8 | (module+ main (void (process-command-line)))
9 |
10 | ; Do not change anything below if you only want subcommands.
11 | (require racket/cmdline
12 | racket/runtime-path
13 | (only-in mzlib/etc this-expression-file-name)
14 | natural-cli)
15 |
16 | (define program-name (get-program-name (this-expression-file-name)))
17 | (define-runtime-path cli-directory ".")
18 |
19 | (define (process-command-line)
20 | (define-values (finish-expr arg-strings-expr help-expr unknown-expr)
21 | (make-subcommand-handlers cli-directory program-name))
22 | (command-line #:program program-name
23 | #:handlers finish-expr arg-strings-expr help-expr unknown-expr))
24 |
--------------------------------------------------------------------------------
/cli/ravk_show_spec.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide process-command-line summary)
4 |
5 | (define summary "Print the Vulkan specification.")
6 |
7 | (module+ main (void (process-command-line)))
8 |
9 | ; Do not change anything below if you only want subcommands.
10 | (require racket/cmdline
11 | racket/runtime-path
12 | racket/port
13 | (only-in mzlib/etc this-expression-file-name)
14 | natural-cli
15 | "../private/txexpr.rkt"
16 | "../private/generate/shared.rkt"
17 | "../spec.rkt"
18 | "./shared.rkt")
19 |
20 | (define program-name (get-program-name (this-expression-file-name)))
21 | (define-runtime-path cli-directory ".")
22 |
23 | (define (process-command-line)
24 | (define show-version (make-parameter #f))
25 | (define show-xexpr (make-parameter #f))
26 | (command-line #:program program-name
27 | #:once-each
28 | [("-x" "--xexpr")
29 | ("Print the output as an X-expression."
30 | "Ignored if -v is set.")
31 | (show-xexpr #t)]
32 | [("-v" "--version")
33 | "Show the spec version instead of its contents."
34 | (show-version #t)])
35 |
36 | (define source (get-source/dynamic))
37 |
38 | (define (extract-header-version registry)
39 | (define (header-version-define? x)
40 | (and (tag=? 'type x)
41 | (equal? (attr-ref x 'category "") "define")
42 | (equal? (get-type-name x) "VK_HEADER_VERSION")))
43 | (define text (shrink-wrap-cdata (findf-txexpr registry header-version-define?)))
44 | (regexp-replace* #px"(?m:\\D+)" text ""))
45 |
46 | (define (extract-spec-version registry)
47 | (define features (findf*-txexpr registry
48 | (λ (x) (and (tag=? 'feature x)
49 | (attrs-have-key? x 'number)))))
50 | (define number-attrs (map (λ (x) (attr-ref x 'number)) features))
51 | (define sorted (sort number-attrs (λ (a b) (> (string->number a) (string->number b)))))
52 | (car sorted))
53 |
54 | (define (display-version)
55 | (define registry (get-vulkan-spec source))
56 | (displayln (string-append (extract-spec-version registry)
57 | "."
58 | (extract-header-version registry))))
59 |
60 | (if (show-version)
61 | (display-version)
62 | (if (show-xexpr)
63 | (writeln (get-vulkan-spec source))
64 | (copy-port (get-spec-port source)
65 | (current-output-port)))))
66 |
--------------------------------------------------------------------------------
/cli/shared.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require "../private/writer.rkt"
5 | "../spec.rkt")
6 |
7 | (define use-latest? (make-parameter #f))
8 | (define (get-source/dynamic) (if (use-latest?) 'remote 'local))
9 | (define (get-vulkan-spec/dynamic) (get-vulkan-spec (get-source/dynamic)))
10 |
11 | (define (write-generated modpath [config #hash()])
12 | (define make-sequence
13 | (dynamic-require (if (string? modpath)
14 | (string->path modpath)
15 | modpath)
16 | 'in-fragment))
17 | (write-sequence (make-sequence (get-vulkan-spec/dynamic) config)))
18 |
--------------------------------------------------------------------------------
/examples/mandelbrot/.gitignore:
--------------------------------------------------------------------------------
1 | *.rgba
2 | *.png
3 |
--------------------------------------------------------------------------------
/examples/mandelbrot/README.md:
--------------------------------------------------------------------------------
1 | This is a Racket port of @Erkaman's `vulkan_minimal_compute` example. To use
2 | everything in this project, you will need the Vulkan SDK installed on your system.
3 |
4 | There are two versions of the program. One uses generated bindings with added conveniences,
5 | and another uses Vulkan's raw API directly. These are the `*-raw.rkt` files.
6 |
7 | Once ready, just execute `racket mandelbrot.rkt` or `racket mandelbrot-raw.rkt`
8 | to render the Mandelbrot set to a PNG. If the program starts too slowly,
9 | run `raco make bindings*.rkt` first.
10 |
11 | `bindings.rkt` was created with the following command:
12 |
13 | ```console
14 | $ ravk generate --enable-auto-check-vkresult \
15 | --enable-symbolic-enums \
16 | ravk generate unsafe > bindings.rkt
17 | ```
18 |
19 | `bindings-raw.rkt` was created using `ravk generate unsafe > bindings-raw.rkt`.
20 |
--------------------------------------------------------------------------------
/examples/mandelbrot/comp.spv:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/zyrolasting/racket-vulkan/1e983e921fb41b59994cea0fc0ebd859ec847186/examples/mandelbrot/comp.spv
--------------------------------------------------------------------------------
/examples/mandelbrot/mandelbrot-raw.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 |
3 | ; Credit @Erkaman for original under MIT License
4 | ; https://github.com/Erkaman/vulkan_minimal_compute
5 | ;
6 | ; Adapted to Racket to test Vulkan FFI bindings and demonstrate that
7 | ; hand-porting C++ to Racket is a feasible means to that end.
8 | ;
9 | ; "The application launches a compute shader that renders the mandelbrot set,
10 | ; by rendering it into a storage buffer. The storage buffer is then read from
11 | ; the GPU, and saved as .png." -- @Erkaman
12 | ;
13 | ; I am changing the comments and program structure as it comes to this module.
14 |
15 | (require racket/runtime-path
16 | ffi/unsafe
17 | ffi/cvector
18 | (only-in racket/draw make-bitmap)
19 | "./bindings-raw.rkt")
20 |
21 | (define (enable-validation-layer?)
22 | (equal? #"true"
23 | (environment-variables-ref
24 | (current-environment-variables)
25 | #"RACKET_VULKAN_ENABLE_VALIDATION_LAYER")))
26 |
27 | (define (two-step-alloc _t f [who 'two-step-alloc])
28 | (define pnum (malloc _uint32_t 'atomic))
29 | (f pnum #f)
30 | (define num (ptr-ref pnum _uint32_t))
31 | (when (= num 0)
32 | (error who "Expected more than zero elements from enumeration."))
33 | (define buf (malloc (* num (ctype-sizeof _t)) 'atomic))
34 | (f pnum buf)
35 | (values num buf))
36 |
37 | (define (make-zero _t [_pointer-type #f])
38 | (define size (ctype-sizeof _t))
39 | (define p (malloc 'atomic size))
40 | (memset p 0 size)
41 | (cpointer-push-tag! p _t)
42 | (if _pointer-type
43 | (cast p
44 | _pointer
45 | _pointer-type)
46 | p))
47 |
48 | (define (create _t f)
49 | (define p (malloc 'atomic _t))
50 | (check (f p))
51 | (ptr-ref p _t))
52 |
53 | (define (_char_array->bytes array)
54 | (apply bytes (filter (λ (b) (> b 0))
55 | (sequence->list (in-array array)))))
56 |
57 | (define-cstruct _pixel
58 | ([r _float]
59 | [g _float]
60 | [b _float]
61 | [a _float]))
62 |
63 | (define (check r)
64 | (when (not (equal? r VK_SUCCESS))
65 | (error 'vulkan "Error code ~a" r)))
66 |
67 | (module+ main
68 | (define with-validation (enable-validation-layer?))
69 | (define layers (get-layers with-validation))
70 | (define extensions (get-extensions with-validation))
71 | (define instance (create-instance layers extensions with-validation))
72 |
73 | (define physical-device (find-physical-device instance))
74 | (define queue-family-index (get-compute-queue-family-index physical-device))
75 | (define logical-device (create-logical-device instance layers physical-device queue-family-index))
76 | (define queue (get-queue logical-device queue-family-index))
77 |
78 | (define width 3200)
79 | (define height 2400)
80 | (define workgroup-size 32)
81 | (define buffer-size (* (ctype-sizeof _pixel) width height))
82 | (define buffer (create-buffer logical-device buffer-size))
83 |
84 | (define buffer-memory (allocate-for-buffer physical-device
85 | logical-device
86 | buffer))
87 |
88 | (define-values (descriptor-set-layout/p descriptor-set-layout)
89 | (create-descriptor-set-layout logical-device))
90 |
91 | (define-values (descriptor-pool/p descriptor-pool)
92 | (create-descriptor-pool logical-device))
93 |
94 | (define-values (descriptor-set/p descriptor-set)
95 | (create-descriptor-set logical-device descriptor-set-layout/p descriptor-pool))
96 |
97 | (connect-buffer-to-descriptor logical-device descriptor-set buffer-size buffer)
98 |
99 | (define shader-module (create-shader-module logical-device))
100 | (define pipeline-layout (create-pipeline-layout logical-device descriptor-set-layout/p))
101 | (define pipeline (create-compute-pipeline logical-device shader-module pipeline-layout))
102 | (define command-pool (create-command-pool logical-device queue-family-index))
103 | (define-values (command-buffer/p command-buffer)
104 | (create-command-buffer logical-device command-pool))
105 |
106 | (record-commands command-buffer
107 | pipeline
108 | pipeline-layout
109 | descriptor-set/p
110 | width
111 | height
112 | workgroup-size)
113 |
114 | (run-command-buffer logical-device
115 | queue
116 | command-buffer/p)
117 |
118 | (dump-bytes logical-device buffer-size buffer-memory width height)
119 |
120 | (vkFreeMemory logical-device buffer-memory #f)
121 | (vkDestroyBuffer logical-device buffer #f)
122 | (vkDestroyShaderModule logical-device shader-module #f)
123 | (vkDestroyDescriptorPool logical-device descriptor-pool #f)
124 | (vkDestroyDescriptorSetLayout logical-device descriptor-set-layout #f)
125 | (vkDestroyPipelineLayout logical-device pipeline-layout #f)
126 | (vkDestroyPipeline logical-device pipeline #f)
127 | (vkDestroyCommandPool logical-device command-pool #f)
128 | (vkDestroyDevice logical-device #f)
129 | (vkDestroyInstance instance #f))
130 |
131 | (define (get-layers with-validation)
132 | (define layer-count/p (malloc _uint32_t 'atomic))
133 | (check (vkEnumerateInstanceLayerProperties layer-count/p #f))
134 | (define layer-count (ptr-ref layer-count/p _uint32_t))
135 | (define layer-properties/p (malloc (* layer-count (ctype-sizeof _VkLayerProperties)) 'atomic))
136 | (check (vkEnumerateInstanceLayerProperties layer-count/p layer-properties/p))
137 |
138 | (define validation-layer-name #"VK_LAYER_KHRONOS_validation")
139 | (define (validation-layer-supported?)
140 | (for/fold ([support #f])
141 | ([offset (in-range layer-count)])
142 | #:break support
143 | (or support
144 | (let ([props (ptr-ref layer-properties/p _VkLayerProperties offset)])
145 | (bytes=? validation-layer-name
146 | (_char_array->bytes (VkLayerProperties-layerName props)))))))
147 |
148 | (when (and with-validation
149 | (not (validation-layer-supported?)))
150 | (error "The validation layer is not available on this system."))
151 |
152 | (if with-validation
153 | (cvector _bytes/nul-terminated validation-layer-name)
154 | (cvector _bytes/nul-terminated)))
155 |
156 |
157 | (define (get-extensions with-validation)
158 | (define extension-count/p (malloc _uint32_t 'atomic))
159 | (check (vkEnumerateInstanceExtensionProperties #f extension-count/p #f))
160 | (define extension-count (ptr-ref extension-count/p _uint32_t))
161 | (define extension-properties/p (malloc (* extension-count (ctype-sizeof _VkExtensionProperties)) 'atomic))
162 | (check (vkEnumerateInstanceExtensionProperties #f extension-count/p extension-properties/p))
163 |
164 | (define debug-extension-name #"VK_EXT_debug_report")
165 | (define (debug-extension-supported?)
166 | (for/fold ([support #f])
167 | ([offset (in-range extension-count)])
168 | #:break support
169 | (or support
170 | (let ([props (ptr-ref extension-properties/p _VkExtensionProperties offset)])
171 | (bytes=? debug-extension-name
172 | (_char_array->bytes (VkExtensionProperties-extensionName props)))))))
173 |
174 | (when (and with-validation
175 | (not (debug-extension-supported?)))
176 | (error "The validation layer is not available on this system."))
177 |
178 | (if with-validation
179 | (cvector _bytes/nul-terminated debug-extension-name)
180 | (cvector _bytes/nul-terminated)))
181 |
182 | (define (create-instance layers extensions with-validation)
183 | (define appInfo (make-VkApplicationInfo VK_STRUCTURE_TYPE_APPLICATION_INFO
184 | #f
185 | #"Mandelbrot"
186 | 0
187 | #"mandelbroteng"
188 | 0
189 | VK_API_VERSION_1_0))
190 |
191 | (define instinfo (make-VkInstanceCreateInfo
192 | VK_STRUCTURE_TYPE_INSTANCE_CREATE_INFO
193 | #f
194 | 0
195 | appInfo
196 | (cvector-length layers)
197 | (cvector-ptr layers)
198 | (cvector-length extensions)
199 | (cvector-ptr extensions)))
200 |
201 | (create _VkInstance
202 | (λ (p) (vkCreateInstance instinfo
203 | #f
204 | p))))
205 |
206 |
207 | (define (find-physical-device instance)
208 | (define pDeviceCount (malloc _uint32_t 'atomic))
209 | (check (vkEnumeratePhysicalDevices instance pDeviceCount #f))
210 | (define num (ptr-ref pDeviceCount _uint32_t))
211 | (when (= num 0)
212 | (error "Expected more than zero physical devices."))
213 | (define size (* num (ctype-sizeof _VkPhysicalDevice)))
214 | (define physical-devices (malloc size 'atomic))
215 | (check (vkEnumeratePhysicalDevices instance pDeviceCount physical-devices))
216 | (define first-device (ptr-ref physical-devices _VkPhysicalDevice 0))
217 | (printf "Assuming first device is good enough.~n")
218 | first-device)
219 |
220 |
221 | (define (get-queue logical-device queue-family-index)
222 | (define queue/p (malloc _VkQueue 'atomic))
223 | (vkGetDeviceQueue logical-device queue-family-index 0 queue/p)
224 | (ptr-ref queue/p _VkQueue))
225 |
226 |
227 | ;; Creates the means to interact with a physical device
228 | (define (create-logical-device instance
229 | layers
230 | physical-device
231 | queue-family-index)
232 | (define queue-priorities/p (malloc _float))
233 | (ptr-set! queue-priorities/p _float 1.0)
234 | (cpointer-push-tag! queue-priorities/p _float)
235 |
236 | (define queue-create-info/p (make-zero _VkDeviceQueueCreateInfo _VkDeviceQueueCreateInfo-pointer))
237 | (define queue-create-info (ptr-ref queue-create-info/p _VkDeviceQueueCreateInfo))
238 | (set-VkDeviceQueueCreateInfo-sType! queue-create-info VK_STRUCTURE_TYPE_DEVICE_QUEUE_CREATE_INFO)
239 | (set-VkDeviceQueueCreateInfo-queueFamilyIndex! queue-create-info queue-family-index)
240 | (set-VkDeviceQueueCreateInfo-queueCount! queue-create-info 1)
241 | (set-VkDeviceQueueCreateInfo-pQueuePriorities! queue-create-info queue-priorities/p)
242 |
243 | (define device-create-info/p (make-zero _VkDeviceCreateInfo))
244 | (define device-create-info (ptr-ref device-create-info/p _VkDeviceCreateInfo))
245 | (define device-features/p (make-zero _VkPhysicalDeviceFeatures _VkPhysicalDeviceFeatures-pointer))
246 | (set-VkDeviceCreateInfo-sType! device-create-info VK_STRUCTURE_TYPE_DEVICE_CREATE_INFO)
247 | (set-VkDeviceCreateInfo-enabledLayerCount! device-create-info (cvector-length layers))
248 | (set-VkDeviceCreateInfo-ppEnabledLayerNames! device-create-info (cvector-ptr layers))
249 | (set-VkDeviceCreateInfo-pQueueCreateInfos! device-create-info queue-create-info/p)
250 | (set-VkDeviceCreateInfo-queueCreateInfoCount! device-create-info 1)
251 | (set-VkDeviceCreateInfo-pEnabledFeatures! device-create-info device-features/p)
252 |
253 | (define logical-device/p (malloc _VkDevice 'atomic))
254 | (check (vkCreateDevice physical-device device-create-info/p #f logical-device/p))
255 |
256 | (ptr-ref logical-device/p _VkDevice))
257 |
258 |
259 | (define (get-compute-queue-family-index physical-device)
260 | (define queue-family-count/p (malloc _uint32_t 'atomic))
261 | (vkGetPhysicalDeviceQueueFamilyProperties physical-device queue-family-count/p #f)
262 | (define queue-family-count (ptr-ref queue-family-count/p _uint32_t))
263 |
264 | (define queue-family-properties/p (malloc (* queue-family-count
265 | (ctype-sizeof _VkQueueFamilyProperties))
266 | 'atomic))
267 |
268 | (vkGetPhysicalDeviceQueueFamilyProperties physical-device
269 | queue-family-count/p
270 | queue-family-properties/p)
271 |
272 | ; Now find a family that supports compute.
273 | (define index
274 | (for/fold ([matching-family-index #f])
275 | ([i (in-range queue-family-count)])
276 | (or matching-family-index
277 | (let ([props (ptr-ref queue-family-properties/p
278 | _VkQueueFamilyProperties
279 | i)])
280 | (if (and (> (VkQueueFamilyProperties-queueCount props) 0)
281 | (> (bitwise-and (VkQueueFamilyProperties-queueFlags props)
282 | VK_QUEUE_COMPUTE_BIT)
283 | 0))
284 | i
285 | #f)))))
286 |
287 |
288 | (when (= index queue-family-count)
289 | (error "No queue family supports compute operations."))
290 |
291 | (printf "Queue family index ~a supports compute operations.~n" index)
292 |
293 | index)
294 |
295 | (define (debug-report-callback flags objectType object location messageCode pLayerPrefix pMessage pUserData)
296 | (log-info "Debug Report: ~a: ~a~n" pLayerPrefix pMessage)
297 | VK_FALSE)
298 |
299 | (define (register-debug-callback instance)
300 | (define drcci/p (make-zero _VkDebugReportCallbackCreateInfoEXT
301 | _VkDebugReportCallbackCreateInfoEXT-pointer))
302 | (define drcci (ptr-ref drcci/p _VkDebugReportCallbackCreateInfoEXT))
303 | (set-VkDebugReportCallbackCreateInfoEXT-sType! drcci VK_STRUCTURE_TYPE_DEBUG_REPORT_CALLBACK_CREATE_INFO_EXT)
304 | (set-VkDebugReportCallbackCreateInfoEXT-flags! drcci (bitwise-ior
305 | VK_DEBUG_REPORT_ERROR_BIT_EXT
306 | VK_DEBUG_REPORT_WARNING_BIT_EXT
307 | VK_DEBUG_REPORT_INFORMATION_BIT_EXT
308 | VK_DEBUG_REPORT_PERFORMANCE_WARNING_BIT_EXT))
309 |
310 | (set-VkDebugReportCallbackCreateInfoEXT-pfnCallback! drcci debug-report-callback)
311 |
312 | (define addr (vkGetInstanceProcAddr instance #"vkCreateDebugReportCallbackEXT"))
313 | (define create-debug-report-callback
314 | (cast addr
315 | _PFN_vkVoidFunction
316 | (_fun _VkInstance
317 | _VkDebugReportCallbackCreateInfoEXT-pointer
318 | _pointer _pointer
319 | -> _VkResult)))
320 |
321 | (define callback/p (malloc _PFN_vkVoidFunction 'atomic))
322 | (check (create-debug-report-callback instance
323 | drcci/p
324 | #f
325 | callback/p))
326 | (ptr-ref callback/p _VkDebugReportCallbackEXT))
327 |
328 | (define (create-buffer logical-device buffer-size)
329 | (define buffer-create-info/p (make-zero _VkBufferCreateInfo _VkBufferCreateInfo-pointer))
330 | (define buffer-create-info (ptr-ref buffer-create-info/p _VkBufferCreateInfo))
331 | (set-VkBufferCreateInfo-sType! buffer-create-info VK_STRUCTURE_TYPE_BUFFER_CREATE_INFO)
332 | (set-VkBufferCreateInfo-size! buffer-create-info buffer-size)
333 | (set-VkBufferCreateInfo-usage! buffer-create-info VK_BUFFER_USAGE_STORAGE_BUFFER_BIT)
334 | (set-VkBufferCreateInfo-sharingMode! buffer-create-info VK_SHARING_MODE_EXCLUSIVE)
335 |
336 | (define buffer/p (malloc _VkBuffer 'atomic))
337 | (check (vkCreateBuffer logical-device buffer-create-info/p #f buffer/p))
338 | (ptr-ref buffer/p _VkBuffer))
339 |
340 | (define (allocate-for-buffer physical-device logical-device buffer)
341 | (define (find-memory-type type-bits properties)
342 | (define pdmp/p (make-zero _VkPhysicalDeviceMemoryProperties
343 | _VkPhysicalDeviceMemoryProperties-pointer))
344 | (vkGetPhysicalDeviceMemoryProperties physical-device pdmp/p)
345 | (define pdmp (ptr-ref pdmp/p _VkPhysicalDeviceMemoryProperties))
346 |
347 | (define ordinals (range (VkPhysicalDeviceMemoryProperties-memoryTypeCount pdmp)))
348 | (or (index-where ordinals
349 | (λ (i)
350 | (and (> (bitwise-and type-bits
351 | (arithmetic-shift i 1))
352 | 0)
353 | (= (bitwise-and
354 | (VkMemoryType-propertyFlags
355 | (array-ref
356 | (VkPhysicalDeviceMemoryProperties-memoryTypes pdmp)
357 | i))
358 | properties)))))
359 | -1))
360 |
361 | (define memory-requirements/p (make-zero _VkMemoryRequirements _VkMemoryRequirements-pointer))
362 | (vkGetBufferMemoryRequirements logical-device buffer memory-requirements/p)
363 | (define memory-requirements (ptr-ref memory-requirements/p _VkMemoryRequirements))
364 |
365 | (define memory-alloc-info/p (make-zero _VkMemoryAllocateInfo _VkMemoryAllocateInfo-pointer))
366 | (define memory-alloc-info (ptr-ref memory-alloc-info/p _VkMemoryAllocateInfo))
367 | (set-VkMemoryAllocateInfo-sType! memory-alloc-info VK_STRUCTURE_TYPE_MEMORY_ALLOCATE_INFO)
368 | (set-VkMemoryAllocateInfo-allocationSize! memory-alloc-info (VkMemoryRequirements-size memory-requirements))
369 | (set-VkMemoryAllocateInfo-memoryTypeIndex! memory-alloc-info
370 | (find-memory-type
371 | (VkMemoryRequirements-memoryTypeBits memory-requirements)
372 | (bitwise-ior VK_MEMORY_PROPERTY_HOST_COHERENT_BIT
373 | VK_MEMORY_PROPERTY_HOST_VISIBLE_BIT)))
374 | (define buffer-memory/p (malloc _VkDeviceMemory 'atomic))
375 | (check (vkAllocateMemory logical-device memory-alloc-info/p #f buffer-memory/p))
376 | (define buffer-memory (ptr-ref buffer-memory/p _VkDeviceMemory))
377 | (vkBindBufferMemory logical-device buffer buffer-memory 0)
378 | buffer-memory)
379 |
380 |
381 | (define (create-descriptor-set-layout logical-device)
382 | (define dslb/p (make-zero _VkDescriptorSetLayoutBinding
383 | _VkDescriptorSetLayoutBinding-pointer))
384 | (define dslb (ptr-ref dslb/p _VkDescriptorSetLayoutBinding))
385 | (set-VkDescriptorSetLayoutBinding-binding! dslb 0)
386 | (set-VkDescriptorSetLayoutBinding-descriptorType! dslb VK_DESCRIPTOR_TYPE_STORAGE_BUFFER)
387 | (set-VkDescriptorSetLayoutBinding-descriptorCount! dslb 1)
388 | (set-VkDescriptorSetLayoutBinding-stageFlags! dslb VK_SHADER_STAGE_COMPUTE_BIT)
389 |
390 | (define dslci/p (make-zero _VkDescriptorSetLayoutCreateInfo
391 | _VkDescriptorSetLayoutCreateInfo-pointer))
392 | (define dslci (ptr-ref dslci/p _VkDescriptorSetLayoutCreateInfo))
393 | (set-VkDescriptorSetLayoutCreateInfo-sType! dslci VK_STRUCTURE_TYPE_DESCRIPTOR_SET_LAYOUT_CREATE_INFO)
394 | (set-VkDescriptorSetLayoutCreateInfo-bindingCount! dslci 1)
395 | (set-VkDescriptorSetLayoutCreateInfo-pBindings! dslci dslb/p)
396 |
397 | (define descriptor-set-layout/p (malloc _VkDescriptorSetLayout 'atomic))
398 | (check (vkCreateDescriptorSetLayout logical-device dslci/p #f descriptor-set-layout/p))
399 | (values descriptor-set-layout/p
400 | (ptr-ref descriptor-set-layout/p _VkDescriptorSetLayout)))
401 |
402 |
403 | (define (create-descriptor-pool logical-device)
404 | (define dps/p (make-zero _VkDescriptorPoolSize _VkDescriptorPoolSize-pointer))
405 | (define dps (ptr-ref dps/p _VkDescriptorPoolSize))
406 | (set-VkDescriptorPoolSize-type! dps VK_DESCRIPTOR_TYPE_STORAGE_BUFFER)
407 | (set-VkDescriptorPoolSize-descriptorCount! dps 1)
408 |
409 | (define dpci/p (make-zero _VkDescriptorPoolCreateInfo _VkDescriptorPoolCreateInfo-pointer))
410 | (define dpci (ptr-ref dpci/p _VkDescriptorPoolCreateInfo))
411 | (set-VkDescriptorPoolCreateInfo-sType! dpci VK_STRUCTURE_TYPE_DESCRIPTOR_POOL_CREATE_INFO)
412 | (set-VkDescriptorPoolCreateInfo-maxSets! dpci 1)
413 | (set-VkDescriptorPoolCreateInfo-poolSizeCount! dpci 1)
414 | (set-VkDescriptorPoolCreateInfo-pPoolSizes! dpci dps/p)
415 |
416 | (define descriptor-pool/p (malloc _VkDescriptorPool 'atomic))
417 | (check (vkCreateDescriptorPool logical-device dpci/p #f descriptor-pool/p))
418 | (values descriptor-pool/p
419 | (ptr-ref descriptor-pool/p _VkDescriptorPool)))
420 |
421 | (define (create-descriptor-set logical-device descriptor-set-layout/p descriptor-pool)
422 | (define dsai/p (make-zero _VkDescriptorSetAllocateInfo _VkDescriptorSetAllocateInfo-pointer))
423 | (define dsai (ptr-ref dsai/p _VkDescriptorSetAllocateInfo))
424 | (set-VkDescriptorSetAllocateInfo-sType! dsai VK_STRUCTURE_TYPE_DESCRIPTOR_SET_ALLOCATE_INFO)
425 | (set-VkDescriptorSetAllocateInfo-descriptorPool! dsai descriptor-pool)
426 | (set-VkDescriptorSetAllocateInfo-descriptorSetCount! dsai 1)
427 | (set-VkDescriptorSetAllocateInfo-pSetLayouts! dsai descriptor-set-layout/p)
428 |
429 | (define descriptor-set/p (malloc _VkDescriptorSet 'atomic))
430 | (check (vkAllocateDescriptorSets logical-device dsai/p descriptor-set/p))
431 | (values descriptor-set/p
432 | (ptr-ref descriptor-set/p _VkDescriptorSet)))
433 |
434 | (define (connect-buffer-to-descriptor logical-device descriptor-set buffer-size buffer)
435 | (define dbi/p (make-zero _VkDescriptorBufferInfo _VkDescriptorBufferInfo-pointer))
436 | (define dbi (ptr-ref dbi/p _VkDescriptorBufferInfo))
437 | (set-VkDescriptorBufferInfo-buffer! dbi buffer)
438 | (set-VkDescriptorBufferInfo-offset! dbi 0)
439 | (set-VkDescriptorBufferInfo-range! dbi buffer-size)
440 |
441 | (define wds/p (make-zero _VkWriteDescriptorSet _VkWriteDescriptorSet-pointer))
442 | (define wds (ptr-ref wds/p _VkWriteDescriptorSet))
443 | (set-VkWriteDescriptorSet-sType! wds VK_STRUCTURE_TYPE_WRITE_DESCRIPTOR_SET)
444 | (set-VkWriteDescriptorSet-dstSet! wds descriptor-set)
445 | (set-VkWriteDescriptorSet-dstBinding! wds 0)
446 | (set-VkWriteDescriptorSet-descriptorCount! wds 1)
447 | (set-VkWriteDescriptorSet-descriptorType! wds VK_DESCRIPTOR_TYPE_STORAGE_BUFFER)
448 | (set-VkWriteDescriptorSet-pBufferInfo! wds dbi/p)
449 |
450 | (vkUpdateDescriptorSets logical-device 1 wds/p 0 #f))
451 |
452 | (define-runtime-path here ".")
453 | (define (create-shader-module logical-device)
454 | (define (read-file)
455 | (call-with-input-file
456 | (build-path here "comp.spv")
457 | (λ (port) (port->bytes port #:close? #f))))
458 |
459 |
460 | (define code (read-file))
461 | (define smci/p (make-zero _VkShaderModuleCreateInfo _VkShaderModuleCreateInfo-pointer))
462 | (define smci (ptr-ref smci/p _VkShaderModuleCreateInfo))
463 | (set-VkShaderModuleCreateInfo-sType! smci VK_STRUCTURE_TYPE_SHADER_MODULE_CREATE_INFO)
464 | (set-VkShaderModuleCreateInfo-pCode! smci code)
465 | (set-VkShaderModuleCreateInfo-codeSize! smci (bytes-length code))
466 |
467 | (define compute-shader-module/p (malloc _VkShaderModule 'atomic))
468 | (check (vkCreateShaderModule logical-device smci/p #f compute-shader-module/p))
469 | (ptr-ref compute-shader-module/p _VkShaderModule))
470 |
471 | (define (create-pipeline-layout logical-device descriptor-set-layout/p)
472 | (define plci/p (make-zero _VkPipelineLayoutCreateInfo
473 | _VkPipelineLayoutCreateInfo-pointer))
474 | (define plci (ptr-ref plci/p _VkPipelineLayoutCreateInfo))
475 | (set-VkPipelineLayoutCreateInfo-sType! plci VK_STRUCTURE_TYPE_PIPELINE_LAYOUT_CREATE_INFO)
476 | (set-VkPipelineLayoutCreateInfo-setLayoutCount! plci 1)
477 | (set-VkPipelineLayoutCreateInfo-pSetLayouts! plci descriptor-set-layout/p)
478 | (define pipeline-layout/p (malloc _VkPipelineLayout 'atomic))
479 | (check (vkCreatePipelineLayout logical-device plci/p #f pipeline-layout/p))
480 | (ptr-ref pipeline-layout/p _VkPipelineLayout))
481 |
482 | (define (create-compute-pipeline logical-device shader-module pipeline-layout)
483 | (define ssci/p (make-zero _VkPipelineShaderStageCreateInfo _VkPipelineShaderStageCreateInfo-pointer))
484 | (define ssci (ptr-ref ssci/p _VkPipelineShaderStageCreateInfo))
485 | (set-VkPipelineShaderStageCreateInfo-sType! ssci VK_STRUCTURE_TYPE_PIPELINE_SHADER_STAGE_CREATE_INFO)
486 | (set-VkPipelineShaderStageCreateInfo-stage! ssci VK_SHADER_STAGE_COMPUTE_BIT)
487 | (set-VkPipelineShaderStageCreateInfo-module! ssci shader-module)
488 | (set-VkPipelineShaderStageCreateInfo-pName! ssci #"main\0")
489 |
490 | (define pci/p (make-zero _VkComputePipelineCreateInfo _VkComputePipelineCreateInfo-pointer))
491 | (define pci (ptr-ref pci/p _VkComputePipelineCreateInfo))
492 | (set-VkComputePipelineCreateInfo-sType! pci VK_STRUCTURE_TYPE_COMPUTE_PIPELINE_CREATE_INFO)
493 | (set-VkComputePipelineCreateInfo-stage! pci ssci)
494 | (set-VkComputePipelineCreateInfo-layout! pci pipeline-layout)
495 |
496 | (define pipeline/p (malloc _VkPipeline 'atomic))
497 | (check (vkCreateComputePipelines logical-device
498 | #f
499 | 1
500 | pci/p
501 | #f
502 | pipeline/p))
503 | (ptr-ref pipeline/p _VkPipeline))
504 |
505 | (define (create-command-pool logical-device queue-family-index)
506 | (define cpci/p (make-zero _VkCommandPoolCreateInfo _VkCommandPoolCreateInfo-pointer))
507 | (define cpci (ptr-ref cpci/p _VkCommandPoolCreateInfo))
508 | (set-VkCommandPoolCreateInfo-sType! cpci VK_STRUCTURE_TYPE_COMMAND_POOL_CREATE_INFO)
509 | (set-VkCommandPoolCreateInfo-flags! cpci 0)
510 | (set-VkCommandPoolCreateInfo-queueFamilyIndex! cpci queue-family-index)
511 |
512 | (define command-pool/p (malloc _VkCommandPool 'atomic))
513 | (check (vkCreateCommandPool logical-device cpci/p #f command-pool/p))
514 | (ptr-ref command-pool/p _VkCommandPool))
515 |
516 |
517 | (define (create-command-buffer logical-device command-pool)
518 | (define cbai/p (make-zero _VkCommandBufferAllocateInfo _VkCommandBufferAllocateInfo-pointer))
519 | (define cbai (ptr-ref cbai/p _VkCommandBufferAllocateInfo))
520 | (set-VkCommandBufferAllocateInfo-sType! cbai VK_STRUCTURE_TYPE_COMMAND_BUFFER_ALLOCATE_INFO)
521 | (set-VkCommandBufferAllocateInfo-commandPool! cbai command-pool)
522 | (set-VkCommandBufferAllocateInfo-level! cbai VK_COMMAND_BUFFER_LEVEL_PRIMARY)
523 | (set-VkCommandBufferAllocateInfo-commandBufferCount! cbai 1)
524 | (define command-buffer/p (malloc _VkCommandBuffer 'atomic))
525 | (check (vkAllocateCommandBuffers logical-device cbai/p command-buffer/p))
526 | (values command-buffer/p
527 | (ptr-ref command-buffer/p _VkCommandBuffer)))
528 |
529 | (define (record-commands command-buffer pipeline pipeline-layout descriptor-set/p width height workgroup-size)
530 | (define cbbi/p (make-zero _VkCommandBufferBeginInfo _VkCommandBufferBeginInfo-pointer))
531 | (define cbbi (ptr-ref cbbi/p _VkCommandBufferBeginInfo))
532 | (set-VkCommandBufferBeginInfo-sType! cbbi VK_STRUCTURE_TYPE_COMMAND_BUFFER_BEGIN_INFO)
533 | (set-VkCommandBufferBeginInfo-flags! cbbi VK_COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT)
534 | (vkBeginCommandBuffer command-buffer cbbi/p)
535 |
536 | (vkCmdBindPipeline command-buffer
537 | VK_PIPELINE_BIND_POINT_COMPUTE
538 | pipeline)
539 |
540 | (vkCmdBindDescriptorSets command-buffer
541 | VK_PIPELINE_BIND_POINT_COMPUTE
542 | pipeline-layout
543 | 0
544 | 1
545 | descriptor-set/p
546 | 0
547 | #f)
548 |
549 | (vkCmdDispatch command-buffer
550 | (inexact->exact (ceiling (/ width (exact->inexact workgroup-size))))
551 | (inexact->exact (ceiling (/ height (exact->inexact workgroup-size))))
552 | 1)
553 |
554 | (vkEndCommandBuffer command-buffer))
555 |
556 | (define (run-command-buffer logical-device queue command-buffer/p)
557 | (define si/p (make-zero _VkSubmitInfo _VkSubmitInfo-pointer))
558 | (define si (ptr-ref si/p _VkSubmitInfo))
559 | (set-VkSubmitInfo-sType! si VK_STRUCTURE_TYPE_SUBMIT_INFO)
560 | (set-VkSubmitInfo-commandBufferCount! si 1)
561 | (set-VkSubmitInfo-pCommandBuffers! si command-buffer/p)
562 |
563 | (define fence/p (malloc _VkFence 'atomic))
564 | (define fci/p (make-zero _VkFenceCreateInfo _VkFenceCreateInfo-pointer))
565 | (define fci (ptr-ref fci/p _VkFenceCreateInfo))
566 | (set-VkFenceCreateInfo-sType! fci VK_STRUCTURE_TYPE_FENCE_CREATE_INFO)
567 | (set-VkFenceCreateInfo-flags! fci 0)
568 | (check (vkCreateFence logical-device fci/p #f fence/p))
569 | (define fence (ptr-ref fence/p _VkFence))
570 |
571 | (vkQueueSubmit queue 1 si/p fence)
572 | (vkWaitForFences logical-device 1 fence/p VK_TRUE #e1e8)
573 | (vkDestroyFence logical-device fence #f))
574 |
575 | (define (dump-bytes logical-device buffer-size buffer-memory width height)
576 | (define byte/p (malloc _pointer 'atomic))
577 | (check (vkMapMemory logical-device buffer-memory 0 buffer-size 0 byte/p))
578 | (define pixel/p (ptr-ref byte/p _pixel-pointer))
579 |
580 | (define (cvt v)
581 | (inexact->exact (truncate (* 255.0 v))))
582 |
583 | (define argb-bytes
584 | (call-with-output-bytes
585 | (λ (port)
586 | (for ([i (in-range (* width height))])
587 | (define pixel (ptr-ref pixel/p _pixel i))
588 | (write-byte (cvt (pixel-a pixel)) port)
589 | (write-byte (cvt (pixel-r pixel)) port)
590 | (write-byte (cvt (pixel-g pixel)) port)
591 | (write-byte (cvt (pixel-b pixel)) port)))))
592 |
593 | (vkUnmapMemory logical-device buffer-memory)
594 |
595 | (define output-file (build-path here "mandelbrot.png"))
596 | (define bitmap (make-bitmap width height))
597 | (send bitmap set-argb-pixels 0 0 width height argb-bytes)
598 | (unless (send bitmap save-file output-file 'png)
599 | (error 'dump-bytes "Saving of file failed: ~a" output-file)))
600 |
--------------------------------------------------------------------------------
/examples/mandelbrot/mandelbrot.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 |
3 | ; Credit @Erkaman for original under MIT License
4 | ; https://github.com/Erkaman/vulkan_minimal_compute
5 | ;
6 | ; Adapted to Racket to test Vulkan FFI bindings and demonstrate that
7 | ; hand-porting C++ to Racket is a feasible means to that end.
8 | ;
9 | ; "The application launches a compute shader that renders the mandelbrot set,
10 | ; by rendering it into a storage buffer. The storage buffer is then read from
11 | ; the GPU, and saved as .png." -- @Erkaman
12 | ;
13 | ; I am changing the comments and program structure as it comes to this module.
14 |
15 | (require racket/runtime-path
16 | ffi/unsafe
17 | ffi/cvector
18 | (only-in racket/draw make-bitmap)
19 | "./bindings.rkt")
20 |
21 | (define (enable-validation-layer?)
22 | (equal? #"true"
23 | (environment-variables-ref
24 | (current-environment-variables)
25 | #"RACKET_VULKAN_ENABLE_VALIDATION_LAYER")))
26 |
27 | (define (two-step-alloc _t f [who 'two-step-alloc])
28 | (define pnum (malloc _uint32_t 'atomic))
29 | (f pnum #f)
30 | (define num (ptr-ref pnum _uint32_t))
31 | (when (= num 0)
32 | (error who "Expected more than zero elements from enumeration."))
33 | (define buf (malloc (* num (ctype-sizeof _t)) 'atomic))
34 | (f pnum buf)
35 | (values num buf))
36 |
37 | (define (make-zero _t [_pointer-type #f])
38 | (define size (ctype-sizeof _t))
39 | (define p (malloc 'atomic size))
40 | (memset p 0 size)
41 | (cpointer-push-tag! p _t)
42 | (if _pointer-type
43 | (cast p
44 | _pointer
45 | _pointer-type)
46 | p))
47 |
48 | (define (create _t f)
49 | (define p (malloc 'atomic _t))
50 | (f p)
51 | (ptr-ref p _t))
52 |
53 | (define (_char_array->bytes array)
54 | (apply bytes (filter (λ (b) (> b 0))
55 | (sequence->list (in-array array)))))
56 |
57 | (define-cstruct _pixel
58 | ([r _float]
59 | [g _float]
60 | [b _float]
61 | [a _float]))
62 |
63 | (module+ main
64 | (define with-validation (enable-validation-layer?))
65 | (define layers (get-layers with-validation))
66 | (define extensions (get-extensions with-validation))
67 | (define instance (create-instance layers extensions with-validation))
68 |
69 | #;(when with-validation
70 | (register-debug-callback instance))
71 |
72 | (define physical-device (find-physical-device instance))
73 | (define queue-family-index (get-compute-queue-family-index physical-device))
74 | (define logical-device (create-logical-device instance layers physical-device queue-family-index))
75 | (define queue (get-queue logical-device queue-family-index))
76 |
77 | (define width 3200)
78 | (define height 2400)
79 | (define workgroup-size 32)
80 | (define buffer-size (* (ctype-sizeof _pixel) width height))
81 | (define buffer (create-buffer logical-device buffer-size))
82 |
83 | (define buffer-memory (allocate-for-buffer physical-device
84 | logical-device
85 | buffer))
86 |
87 | (define-values (descriptor-set-layout/p descriptor-set-layout)
88 | (create-descriptor-set-layout logical-device))
89 |
90 | (define-values (descriptor-pool/p descriptor-pool)
91 | (create-descriptor-pool logical-device))
92 |
93 | (define-values (descriptor-set/p descriptor-set)
94 | (create-descriptor-set logical-device descriptor-set-layout/p descriptor-pool))
95 |
96 | (connect-buffer-to-descriptor logical-device descriptor-set buffer-size buffer)
97 |
98 | (define shader-module (create-shader-module logical-device))
99 | (define pipeline-layout (create-pipeline-layout logical-device descriptor-set-layout/p))
100 | (define pipeline (create-compute-pipeline logical-device shader-module pipeline-layout))
101 | (define command-pool (create-command-pool logical-device queue-family-index))
102 | (define-values (command-buffer/p command-buffer)
103 | (create-command-buffer logical-device command-pool))
104 |
105 | (record-commands command-buffer
106 | pipeline
107 | pipeline-layout
108 | descriptor-set/p
109 | width
110 | height
111 | workgroup-size)
112 |
113 | (run-command-buffer logical-device
114 | queue
115 | command-buffer/p)
116 |
117 | (dump-bytes logical-device buffer-size buffer-memory width height)
118 |
119 | (vkFreeMemory logical-device buffer-memory #f)
120 | (vkDestroyBuffer logical-device buffer #f)
121 | (vkDestroyShaderModule logical-device shader-module #f)
122 | (vkDestroyDescriptorPool logical-device descriptor-pool #f)
123 | (vkDestroyDescriptorSetLayout logical-device descriptor-set-layout #f)
124 | (vkDestroyPipelineLayout logical-device pipeline-layout #f)
125 | (vkDestroyPipeline logical-device pipeline #f)
126 | (vkDestroyCommandPool logical-device command-pool #f)
127 | (vkDestroyDevice logical-device #f)
128 | (vkDestroyInstance instance #f))
129 |
130 | (define (get-layers with-validation)
131 | (define layer-count/p (malloc _uint32_t 'atomic))
132 | (vkEnumerateInstanceLayerProperties layer-count/p #f)
133 | (define layer-count (ptr-ref layer-count/p _uint32_t))
134 | (define layer-properties/p (malloc (* layer-count (ctype-sizeof _VkLayerProperties)) 'atomic))
135 | (vkEnumerateInstanceLayerProperties layer-count/p layer-properties/p)
136 |
137 | (define validation-layer-name #"VK_LAYER_KHRONOS_validation")
138 | (define (validation-layer-supported?)
139 | (for/fold ([support #f])
140 | ([offset (in-range layer-count)])
141 | #:break support
142 | (or support
143 | (let ([props (ptr-ref layer-properties/p _VkLayerProperties offset)])
144 | (bytes=? validation-layer-name
145 | (_char_array->bytes (VkLayerProperties-layerName props)))))))
146 |
147 | (when (and with-validation
148 | (not (validation-layer-supported?)))
149 | (error "The validation layer is not available on this system."))
150 |
151 | (if with-validation
152 | (cvector _bytes/nul-terminated validation-layer-name)
153 | (cvector _bytes/nul-terminated)))
154 |
155 |
156 | (define (get-extensions with-validation)
157 | (define extension-count/p (malloc _uint32_t 'atomic))
158 | (vkEnumerateInstanceExtensionProperties #f extension-count/p #f)
159 | (define extension-count (ptr-ref extension-count/p _uint32_t))
160 | (define extension-properties/p (malloc (* extension-count (ctype-sizeof _VkExtensionProperties)) 'atomic))
161 | (vkEnumerateInstanceExtensionProperties #f extension-count/p extension-properties/p)
162 |
163 | (define debug-extension-name #"VK_EXT_debug_report")
164 | (define (debug-extension-supported?)
165 | (for/fold ([support #f])
166 | ([offset (in-range extension-count)])
167 | #:break support
168 | (or support
169 | (let ([props (ptr-ref extension-properties/p _VkExtensionProperties offset)])
170 | (bytes=? debug-extension-name
171 | (_char_array->bytes (VkExtensionProperties-extensionName props)))))))
172 |
173 | (when (and with-validation
174 | (not (debug-extension-supported?)))
175 | (error "The validation layer is not available on this system."))
176 |
177 | (if with-validation
178 | (cvector _bytes/nul-terminated debug-extension-name)
179 | (cvector _bytes/nul-terminated)))
180 |
181 | (define (create-instance layers extensions with-validation)
182 | (define appInfo (make-VkApplicationInfo 'VK_STRUCTURE_TYPE_APPLICATION_INFO
183 | #f
184 | #"Mandelbrot"
185 | 0
186 | #"mandelbroteng"
187 | 0
188 | VK_API_VERSION_1_0))
189 |
190 | (define instinfo (make-VkInstanceCreateInfo
191 | 'VK_STRUCTURE_TYPE_INSTANCE_CREATE_INFO
192 | #f
193 | 0
194 | appInfo
195 | (cvector-length layers)
196 | (cvector-ptr layers)
197 | (cvector-length extensions)
198 | (cvector-ptr extensions)))
199 |
200 | (create _VkInstance
201 | (λ (p) (vkCreateInstance instinfo
202 | #f
203 | p))))
204 |
205 |
206 | (define (find-physical-device instance)
207 | (define pDeviceCount (malloc _uint32_t 'atomic))
208 | (vkEnumeratePhysicalDevices instance pDeviceCount #f)
209 | (define num (ptr-ref pDeviceCount _uint32_t))
210 | (when (= num 0)
211 | (error "Expected more than zero physical devices."))
212 | (define size (* num (ctype-sizeof _VkPhysicalDevice)))
213 | (define physical-devices (malloc size 'atomic))
214 | (vkEnumeratePhysicalDevices instance pDeviceCount physical-devices)
215 | (define first-device (ptr-ref physical-devices _VkPhysicalDevice 0))
216 | (printf "Assuming first device is good enough.~n")
217 | first-device)
218 |
219 |
220 | (define (get-queue logical-device queue-family-index)
221 | (define queue/p (malloc _VkQueue 'atomic))
222 | (vkGetDeviceQueue logical-device queue-family-index 0 queue/p)
223 | (ptr-ref queue/p _VkQueue))
224 |
225 |
226 | ;; Creates the means to interact with a physical device
227 | (define (create-logical-device instance
228 | layers
229 | physical-device
230 | queue-family-index)
231 | (define queue-priorities/p (malloc _float))
232 | (ptr-set! queue-priorities/p _float 1.0)
233 | (cpointer-push-tag! queue-priorities/p _float)
234 |
235 | (define queue-create-info/p (make-zero _VkDeviceQueueCreateInfo _VkDeviceQueueCreateInfo-pointer))
236 | (define queue-create-info (ptr-ref queue-create-info/p _VkDeviceQueueCreateInfo))
237 | (set-VkDeviceQueueCreateInfo-sType! queue-create-info 'VK_STRUCTURE_TYPE_DEVICE_QUEUE_CREATE_INFO)
238 | (set-VkDeviceQueueCreateInfo-queueFamilyIndex! queue-create-info queue-family-index)
239 | (set-VkDeviceQueueCreateInfo-queueCount! queue-create-info 1)
240 | (set-VkDeviceQueueCreateInfo-pQueuePriorities! queue-create-info queue-priorities/p)
241 |
242 | (define device-create-info/p (make-zero _VkDeviceCreateInfo))
243 | (define device-create-info (ptr-ref device-create-info/p _VkDeviceCreateInfo))
244 | (define device-features/p (make-zero _VkPhysicalDeviceFeatures _VkPhysicalDeviceFeatures-pointer))
245 | (set-VkDeviceCreateInfo-sType! device-create-info 'VK_STRUCTURE_TYPE_DEVICE_CREATE_INFO)
246 | (set-VkDeviceCreateInfo-enabledLayerCount! device-create-info (cvector-length layers))
247 | (set-VkDeviceCreateInfo-ppEnabledLayerNames! device-create-info (cvector-ptr layers))
248 | (set-VkDeviceCreateInfo-pQueueCreateInfos! device-create-info queue-create-info/p)
249 | (set-VkDeviceCreateInfo-queueCreateInfoCount! device-create-info 1)
250 | (set-VkDeviceCreateInfo-pEnabledFeatures! device-create-info device-features/p)
251 |
252 | (define logical-device/p (malloc _VkDevice 'atomic))
253 | (vkCreateDevice physical-device device-create-info/p #f logical-device/p)
254 |
255 | (ptr-ref logical-device/p _VkDevice))
256 |
257 |
258 | (define (get-compute-queue-family-index physical-device)
259 | (define queue-family-count/p (malloc _uint32_t 'atomic))
260 | (vkGetPhysicalDeviceQueueFamilyProperties physical-device queue-family-count/p #f)
261 | (define queue-family-count (ptr-ref queue-family-count/p _uint32_t))
262 |
263 | (define queue-family-properties/p (malloc (* queue-family-count
264 | (ctype-sizeof _VkQueueFamilyProperties))
265 | 'atomic))
266 |
267 | (vkGetPhysicalDeviceQueueFamilyProperties physical-device
268 | queue-family-count/p
269 | queue-family-properties/p)
270 |
271 | ; Now find a family that supports compute.
272 | (define index
273 | (for/fold ([matching-family-index #f])
274 | ([i (in-range queue-family-count)])
275 | (or matching-family-index
276 | (let ([props (ptr-ref queue-family-properties/p
277 | _VkQueueFamilyProperties
278 | i)])
279 | (if (and (> (VkQueueFamilyProperties-queueCount props) 0)
280 | (> (bitwise-and (VkQueueFamilyProperties-queueFlags props)
281 | VK_QUEUE_COMPUTE_BIT)
282 | 0))
283 | i
284 | #f)))))
285 |
286 |
287 | (when (= index queue-family-count)
288 | (error "No queue family supports compute operations."))
289 |
290 | (printf "Queue family index ~a supports compute operations.~n" index)
291 |
292 | index)
293 |
294 | (define (debug-report-callback flags objectType object location messageCode pLayerPrefix pMessage pUserData)
295 | (log-info "Debug Report: ~a: ~a~n" pLayerPrefix pMessage)
296 | VK_FALSE)
297 |
298 | (define (register-debug-callback instance)
299 | (define drcci/p (make-zero _VkDebugReportCallbackCreateInfoEXT
300 | _VkDebugReportCallbackCreateInfoEXT-pointer))
301 | (define drcci (ptr-ref drcci/p _VkDebugReportCallbackCreateInfoEXT))
302 | (set-VkDebugReportCallbackCreateInfoEXT-sType! drcci 'VK_STRUCTURE_TYPE_DEBUG_REPORT_CALLBACK_CREATE_INFO_EXT)
303 | (set-VkDebugReportCallbackCreateInfoEXT-flags! drcci (bitwise-ior
304 | VK_DEBUG_REPORT_ERROR_BIT_EXT
305 | VK_DEBUG_REPORT_WARNING_BIT_EXT
306 | VK_DEBUG_REPORT_INFORMATION_BIT_EXT
307 | VK_DEBUG_REPORT_PERFORMANCE_WARNING_BIT_EXT))
308 |
309 | (set-VkDebugReportCallbackCreateInfoEXT-pfnCallback! drcci debug-report-callback)
310 |
311 | (define addr (vkGetInstanceProcAddr instance #"vkCreateDebugReportCallbackEXT"))
312 | (define create-debug-report-callback
313 | (cast addr
314 | _PFN_vkVoidFunction
315 | (_fun _VkInstance
316 | _VkDebugReportCallbackCreateInfoEXT-pointer
317 | _pointer _pointer
318 | -> _VkResult)))
319 |
320 | (define callback/p (malloc _PFN_vkVoidFunction 'atomic))
321 | (check-vkResult (create-debug-report-callback instance
322 | drcci/p
323 | #f
324 | callback/p))
325 | (ptr-ref callback/p _VkDebugReportCallbackEXT))
326 |
327 | (define (create-buffer logical-device buffer-size)
328 | (define buffer-create-info/p (make-zero _VkBufferCreateInfo _VkBufferCreateInfo-pointer))
329 | (define buffer-create-info (ptr-ref buffer-create-info/p _VkBufferCreateInfo))
330 | (set-VkBufferCreateInfo-sType! buffer-create-info 'VK_STRUCTURE_TYPE_BUFFER_CREATE_INFO)
331 | (set-VkBufferCreateInfo-size! buffer-create-info buffer-size)
332 | (set-VkBufferCreateInfo-usage! buffer-create-info VK_BUFFER_USAGE_STORAGE_BUFFER_BIT)
333 | (set-VkBufferCreateInfo-sharingMode! buffer-create-info 'VK_SHARING_MODE_EXCLUSIVE)
334 |
335 | (define buffer/p (malloc _VkBuffer 'atomic))
336 | (vkCreateBuffer logical-device buffer-create-info/p #f buffer/p)
337 | (ptr-ref buffer/p _VkBuffer))
338 |
339 | (define (allocate-for-buffer physical-device logical-device buffer)
340 | (define (find-memory-type type-bits properties)
341 | (define pdmp/p (make-zero _VkPhysicalDeviceMemoryProperties
342 | _VkPhysicalDeviceMemoryProperties-pointer))
343 | (vkGetPhysicalDeviceMemoryProperties physical-device pdmp/p)
344 | (define pdmp (ptr-ref pdmp/p _VkPhysicalDeviceMemoryProperties))
345 |
346 | (define ordinals (range (VkPhysicalDeviceMemoryProperties-memoryTypeCount pdmp)))
347 | (or (index-where ordinals
348 | (λ (i)
349 | (and (> (bitwise-and type-bits
350 | (arithmetic-shift i 1))
351 | 0)
352 | (= (bitwise-and
353 | (VkMemoryType-propertyFlags
354 | (array-ref
355 | (VkPhysicalDeviceMemoryProperties-memoryTypes pdmp)
356 | i))
357 | properties)))))
358 | -1))
359 |
360 | (define memory-requirements/p (make-zero _VkMemoryRequirements _VkMemoryRequirements-pointer))
361 | (vkGetBufferMemoryRequirements logical-device buffer memory-requirements/p)
362 | (define memory-requirements (ptr-ref memory-requirements/p _VkMemoryRequirements))
363 |
364 | (define memory-alloc-info/p (make-zero _VkMemoryAllocateInfo _VkMemoryAllocateInfo-pointer))
365 | (define memory-alloc-info (ptr-ref memory-alloc-info/p _VkMemoryAllocateInfo))
366 | (set-VkMemoryAllocateInfo-sType! memory-alloc-info 'VK_STRUCTURE_TYPE_MEMORY_ALLOCATE_INFO)
367 | (set-VkMemoryAllocateInfo-allocationSize! memory-alloc-info (VkMemoryRequirements-size memory-requirements))
368 | (set-VkMemoryAllocateInfo-memoryTypeIndex! memory-alloc-info
369 | (find-memory-type
370 | (VkMemoryRequirements-memoryTypeBits memory-requirements)
371 | (bitwise-ior VK_MEMORY_PROPERTY_HOST_COHERENT_BIT
372 | VK_MEMORY_PROPERTY_HOST_VISIBLE_BIT)))
373 | (define buffer-memory/p (malloc _VkDeviceMemory 'atomic))
374 | (vkAllocateMemory logical-device memory-alloc-info/p #f buffer-memory/p)
375 | (define buffer-memory (ptr-ref buffer-memory/p _VkDeviceMemory))
376 | (vkBindBufferMemory logical-device buffer buffer-memory 0)
377 | buffer-memory)
378 |
379 |
380 | (define (create-descriptor-set-layout logical-device)
381 | (define dslb/p (make-zero _VkDescriptorSetLayoutBinding
382 | _VkDescriptorSetLayoutBinding-pointer))
383 | (define dslb (ptr-ref dslb/p _VkDescriptorSetLayoutBinding))
384 | (set-VkDescriptorSetLayoutBinding-binding! dslb 0)
385 | (set-VkDescriptorSetLayoutBinding-descriptorType! dslb 'VK_DESCRIPTOR_TYPE_STORAGE_BUFFER)
386 | (set-VkDescriptorSetLayoutBinding-descriptorCount! dslb 1)
387 | (set-VkDescriptorSetLayoutBinding-stageFlags! dslb VK_SHADER_STAGE_COMPUTE_BIT)
388 |
389 | (define dslci/p (make-zero _VkDescriptorSetLayoutCreateInfo
390 | _VkDescriptorSetLayoutCreateInfo-pointer))
391 | (define dslci (ptr-ref dslci/p _VkDescriptorSetLayoutCreateInfo))
392 | (set-VkDescriptorSetLayoutCreateInfo-sType! dslci 'VK_STRUCTURE_TYPE_DESCRIPTOR_SET_LAYOUT_CREATE_INFO)
393 | (set-VkDescriptorSetLayoutCreateInfo-bindingCount! dslci 1)
394 | (set-VkDescriptorSetLayoutCreateInfo-pBindings! dslci dslb/p)
395 |
396 | (define descriptor-set-layout/p (malloc _VkDescriptorSetLayout 'atomic))
397 | (vkCreateDescriptorSetLayout logical-device dslci/p #f descriptor-set-layout/p)
398 | (values descriptor-set-layout/p
399 | (ptr-ref descriptor-set-layout/p _VkDescriptorSetLayout)))
400 |
401 |
402 | (define (create-descriptor-pool logical-device)
403 | (define dps/p (make-zero _VkDescriptorPoolSize _VkDescriptorPoolSize-pointer))
404 | (define dps (ptr-ref dps/p _VkDescriptorPoolSize))
405 | (set-VkDescriptorPoolSize-type! dps 'VK_DESCRIPTOR_TYPE_STORAGE_BUFFER)
406 | (set-VkDescriptorPoolSize-descriptorCount! dps 1)
407 |
408 | (define dpci/p (make-zero _VkDescriptorPoolCreateInfo _VkDescriptorPoolCreateInfo-pointer))
409 | (define dpci (ptr-ref dpci/p _VkDescriptorPoolCreateInfo))
410 | (set-VkDescriptorPoolCreateInfo-sType! dpci 'VK_STRUCTURE_TYPE_DESCRIPTOR_POOL_CREATE_INFO)
411 | (set-VkDescriptorPoolCreateInfo-maxSets! dpci 1)
412 | (set-VkDescriptorPoolCreateInfo-poolSizeCount! dpci 1)
413 | (set-VkDescriptorPoolCreateInfo-pPoolSizes! dpci dps/p)
414 |
415 | (define descriptor-pool/p (malloc _VkDescriptorPool 'atomic))
416 | (vkCreateDescriptorPool logical-device dpci/p #f descriptor-pool/p)
417 | (values descriptor-pool/p
418 | (ptr-ref descriptor-pool/p _VkDescriptorPool)))
419 |
420 | (define (create-descriptor-set logical-device descriptor-set-layout/p descriptor-pool)
421 | (define dsai/p (make-zero _VkDescriptorSetAllocateInfo _VkDescriptorSetAllocateInfo-pointer))
422 | (define dsai (ptr-ref dsai/p _VkDescriptorSetAllocateInfo))
423 | (set-VkDescriptorSetAllocateInfo-sType! dsai 'VK_STRUCTURE_TYPE_DESCRIPTOR_SET_ALLOCATE_INFO)
424 | (set-VkDescriptorSetAllocateInfo-descriptorPool! dsai descriptor-pool)
425 | (set-VkDescriptorSetAllocateInfo-descriptorSetCount! dsai 1)
426 | (set-VkDescriptorSetAllocateInfo-pSetLayouts! dsai descriptor-set-layout/p)
427 |
428 | (define descriptor-set/p (malloc _VkDescriptorSet 'atomic))
429 | (vkAllocateDescriptorSets logical-device dsai/p descriptor-set/p)
430 | (values descriptor-set/p
431 | (ptr-ref descriptor-set/p _VkDescriptorSet)))
432 |
433 | (define (connect-buffer-to-descriptor logical-device descriptor-set buffer-size buffer)
434 | (define dbi/p (make-zero _VkDescriptorBufferInfo _VkDescriptorBufferInfo-pointer))
435 | (define dbi (ptr-ref dbi/p _VkDescriptorBufferInfo))
436 | (set-VkDescriptorBufferInfo-buffer! dbi buffer)
437 | (set-VkDescriptorBufferInfo-offset! dbi 0)
438 | (set-VkDescriptorBufferInfo-range! dbi buffer-size)
439 |
440 | (define wds/p (make-zero _VkWriteDescriptorSet _VkWriteDescriptorSet-pointer))
441 | (define wds (ptr-ref wds/p _VkWriteDescriptorSet))
442 | (set-VkWriteDescriptorSet-sType! wds 'VK_STRUCTURE_TYPE_WRITE_DESCRIPTOR_SET)
443 | (set-VkWriteDescriptorSet-dstSet! wds descriptor-set)
444 | (set-VkWriteDescriptorSet-dstBinding! wds 0)
445 | (set-VkWriteDescriptorSet-descriptorCount! wds 1)
446 | (set-VkWriteDescriptorSet-descriptorType! wds 'VK_DESCRIPTOR_TYPE_STORAGE_BUFFER)
447 | (set-VkWriteDescriptorSet-pBufferInfo! wds dbi/p)
448 |
449 | (vkUpdateDescriptorSets logical-device 1 wds/p 0 #f))
450 |
451 | (define-runtime-path here ".")
452 | (define (create-shader-module logical-device)
453 | (define (read-file)
454 | (call-with-input-file
455 | (build-path here "comp.spv")
456 | (λ (port) (port->bytes port #:close? #f))))
457 |
458 |
459 | (define code (read-file))
460 | (define smci/p (make-zero _VkShaderModuleCreateInfo _VkShaderModuleCreateInfo-pointer))
461 | (define smci (ptr-ref smci/p _VkShaderModuleCreateInfo))
462 | (set-VkShaderModuleCreateInfo-sType! smci 'VK_STRUCTURE_TYPE_SHADER_MODULE_CREATE_INFO)
463 | (set-VkShaderModuleCreateInfo-pCode! smci code)
464 | (set-VkShaderModuleCreateInfo-codeSize! smci (bytes-length code))
465 |
466 | (define compute-shader-module/p (malloc _VkShaderModule 'atomic))
467 | (vkCreateShaderModule logical-device smci/p #f compute-shader-module/p)
468 | (ptr-ref compute-shader-module/p _VkShaderModule))
469 |
470 | (define (create-pipeline-layout logical-device descriptor-set-layout/p)
471 | (define plci/p (make-zero _VkPipelineLayoutCreateInfo
472 | _VkPipelineLayoutCreateInfo-pointer))
473 | (define plci (ptr-ref plci/p _VkPipelineLayoutCreateInfo))
474 | (set-VkPipelineLayoutCreateInfo-sType! plci 'VK_STRUCTURE_TYPE_PIPELINE_LAYOUT_CREATE_INFO)
475 | (set-VkPipelineLayoutCreateInfo-setLayoutCount! plci 1)
476 | (set-VkPipelineLayoutCreateInfo-pSetLayouts! plci descriptor-set-layout/p)
477 | (define pipeline-layout/p (malloc _VkPipelineLayout 'atomic))
478 | (vkCreatePipelineLayout logical-device plci/p #f pipeline-layout/p)
479 | (ptr-ref pipeline-layout/p _VkPipelineLayout))
480 |
481 | (define (create-compute-pipeline logical-device shader-module pipeline-layout)
482 | (define ssci/p (make-zero _VkPipelineShaderStageCreateInfo _VkPipelineShaderStageCreateInfo-pointer))
483 | (define ssci (ptr-ref ssci/p _VkPipelineShaderStageCreateInfo))
484 | (set-VkPipelineShaderStageCreateInfo-sType! ssci 'VK_STRUCTURE_TYPE_PIPELINE_SHADER_STAGE_CREATE_INFO)
485 | (set-VkPipelineShaderStageCreateInfo-stage! ssci 'VK_SHADER_STAGE_COMPUTE_BIT)
486 | (set-VkPipelineShaderStageCreateInfo-module! ssci shader-module)
487 | (set-VkPipelineShaderStageCreateInfo-pName! ssci #"main\0")
488 |
489 | (define pci/p (make-zero _VkComputePipelineCreateInfo _VkComputePipelineCreateInfo-pointer))
490 | (define pci (ptr-ref pci/p _VkComputePipelineCreateInfo))
491 | (set-VkComputePipelineCreateInfo-sType! pci 'VK_STRUCTURE_TYPE_COMPUTE_PIPELINE_CREATE_INFO)
492 | (set-VkComputePipelineCreateInfo-stage! pci ssci)
493 | (set-VkComputePipelineCreateInfo-layout! pci pipeline-layout)
494 |
495 | (define pipeline/p (malloc _VkPipeline 'atomic))
496 | (vkCreateComputePipelines logical-device
497 | #f
498 | 1
499 | pci/p
500 | #f
501 | pipeline/p)
502 | (ptr-ref pipeline/p _VkPipeline))
503 |
504 | (define (create-command-pool logical-device queue-family-index)
505 | (define cpci/p (make-zero _VkCommandPoolCreateInfo _VkCommandPoolCreateInfo-pointer))
506 | (define cpci (ptr-ref cpci/p _VkCommandPoolCreateInfo))
507 | (set-VkCommandPoolCreateInfo-sType! cpci 'VK_STRUCTURE_TYPE_COMMAND_POOL_CREATE_INFO)
508 | (set-VkCommandPoolCreateInfo-flags! cpci 0)
509 | (set-VkCommandPoolCreateInfo-queueFamilyIndex! cpci queue-family-index)
510 |
511 | (define command-pool/p (malloc _VkCommandPool 'atomic))
512 | (vkCreateCommandPool logical-device cpci/p #f command-pool/p)
513 | (ptr-ref command-pool/p _VkCommandPool))
514 |
515 |
516 | (define (create-command-buffer logical-device command-pool)
517 | (define cbai/p (make-zero _VkCommandBufferAllocateInfo _VkCommandBufferAllocateInfo-pointer))
518 | (define cbai (ptr-ref cbai/p _VkCommandBufferAllocateInfo))
519 | (set-VkCommandBufferAllocateInfo-sType! cbai 'VK_STRUCTURE_TYPE_COMMAND_BUFFER_ALLOCATE_INFO)
520 | (set-VkCommandBufferAllocateInfo-commandPool! cbai command-pool)
521 | (set-VkCommandBufferAllocateInfo-level! cbai 'VK_COMMAND_BUFFER_LEVEL_PRIMARY)
522 | (set-VkCommandBufferAllocateInfo-commandBufferCount! cbai 1)
523 | (define command-buffer/p (malloc _VkCommandBuffer 'atomic))
524 | (vkAllocateCommandBuffers logical-device cbai/p command-buffer/p)
525 | (values command-buffer/p
526 | (ptr-ref command-buffer/p _VkCommandBuffer)))
527 |
528 | (define (record-commands command-buffer pipeline pipeline-layout descriptor-set/p width height workgroup-size)
529 | (define cbbi/p (make-zero _VkCommandBufferBeginInfo _VkCommandBufferBeginInfo-pointer))
530 | (define cbbi (ptr-ref cbbi/p _VkCommandBufferBeginInfo))
531 | (set-VkCommandBufferBeginInfo-sType! cbbi 'VK_STRUCTURE_TYPE_COMMAND_BUFFER_BEGIN_INFO)
532 | (set-VkCommandBufferBeginInfo-flags! cbbi VK_COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT)
533 | (vkBeginCommandBuffer command-buffer cbbi/p)
534 |
535 | (vkCmdBindPipeline command-buffer
536 | 'VK_PIPELINE_BIND_POINT_COMPUTE
537 | pipeline)
538 |
539 | (vkCmdBindDescriptorSets command-buffer
540 | 'VK_PIPELINE_BIND_POINT_COMPUTE
541 | pipeline-layout
542 | 0
543 | 1
544 | descriptor-set/p
545 | 0
546 | #f)
547 |
548 | (vkCmdDispatch command-buffer
549 | (inexact->exact (ceiling (/ width (exact->inexact workgroup-size))))
550 | (inexact->exact (ceiling (/ height (exact->inexact workgroup-size))))
551 | 1)
552 |
553 | (vkEndCommandBuffer command-buffer))
554 |
555 | (define (run-command-buffer logical-device queue command-buffer/p)
556 | (define si/p (make-zero _VkSubmitInfo _VkSubmitInfo-pointer))
557 | (define si (ptr-ref si/p _VkSubmitInfo))
558 | (set-VkSubmitInfo-sType! si 'VK_STRUCTURE_TYPE_SUBMIT_INFO)
559 | (set-VkSubmitInfo-commandBufferCount! si 1)
560 | (set-VkSubmitInfo-pCommandBuffers! si command-buffer/p)
561 |
562 | (define fence/p (malloc _VkFence 'atomic))
563 | (define fci/p (make-zero _VkFenceCreateInfo _VkFenceCreateInfo-pointer))
564 | (define fci (ptr-ref fci/p _VkFenceCreateInfo))
565 | (set-VkFenceCreateInfo-sType! fci 'VK_STRUCTURE_TYPE_FENCE_CREATE_INFO)
566 | (set-VkFenceCreateInfo-flags! fci 0)
567 | (vkCreateFence logical-device fci/p #f fence/p)
568 | (define fence (ptr-ref fence/p _VkFence))
569 |
570 | (vkQueueSubmit queue 1 si/p fence)
571 | (vkWaitForFences logical-device 1 fence/p VK_TRUE #e1e8)
572 | (vkDestroyFence logical-device fence #f))
573 |
574 | (define (dump-bytes logical-device buffer-size buffer-memory width height)
575 | (define byte/p (malloc _pointer 'atomic))
576 | (vkMapMemory logical-device buffer-memory 0 buffer-size 0 byte/p)
577 | (define pixel/p (ptr-ref byte/p _pixel-pointer))
578 |
579 | (define (cvt v)
580 | (inexact->exact (truncate (* 255.0 v))))
581 |
582 | (define argb-bytes
583 | (call-with-output-bytes
584 | (λ (port)
585 | (for ([i (in-range (* width height))])
586 | (define pixel (ptr-ref pixel/p _pixel i))
587 | (write-byte (cvt (pixel-a pixel)) port)
588 | (write-byte (cvt (pixel-r pixel)) port)
589 | (write-byte (cvt (pixel-g pixel)) port)
590 | (write-byte (cvt (pixel-b pixel)) port)))))
591 |
592 | (vkUnmapMemory logical-device buffer-memory)
593 |
594 | (define output-file (build-path here "mandelbrot.png"))
595 | (define bitmap (make-bitmap width height))
596 | (send bitmap set-argb-pixels 0 0 width height argb-bytes)
597 | (unless (send bitmap save-file output-file 'png)
598 | (error 'dump-bytes "Saving of file failed: ~a" output-file)))
599 |
--------------------------------------------------------------------------------
/examples/minimal.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (require vulkan/unsafe
4 | ffi/unsafe)
5 |
6 | (define appinfo
7 | (make-VkApplicationInfo VK_STRUCTURE_TYPE_APPLICATION_INFO
8 | #f
9 | #"Minimal Vulkan"
10 | 0
11 | #"Engine"
12 | 0
13 | VK_API_VERSION_1_0))
14 | (define instcreateinfo
15 | (make-VkInstanceCreateInfo
16 | VK_STRUCTURE_TYPE_INSTANCE_CREATE_INFO
17 | #f
18 | 0
19 | appinfo
20 | 0
21 | #f
22 | 0
23 | #f))
24 |
25 | (define instance-ptr (malloc _VkInstance))
26 | (vkCreateInstance instcreateinfo #f instance-ptr)
27 | (define instance (ptr-ref instance-ptr _VkInstance))
28 | (vkDestroyInstance instance #f)
29 |
--------------------------------------------------------------------------------
/examples/physical-device-report.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ; Reports physical device information.
4 | (require racket/sequence
5 | racket/string
6 | vulkan/unsafe
7 | ffi/unsafe)
8 |
9 | (define (create _t f)
10 | (define p (malloc _t 'atomic))
11 | (f p)
12 | (ptr-ref p _t))
13 |
14 | (define (format-uuid numbers)
15 | (string-upcase
16 | (apply format (string-replace "xxxx-xx-xx-xx-xxxxxx"
17 | "x" "~x")
18 | numbers)))
19 |
20 | (define (print-physical-device-properties props)
21 | (define (<< name val)
22 | (printf "~a: ~a~n" name val))
23 |
24 | (<< "API Version" (let ([v (VkPhysicalDeviceProperties-apiVersion props)])
25 | (format "~a.~a.~a"
26 | (VK_VERSION_MAJOR v)
27 | (VK_VERSION_MINOR v)
28 | (VK_VERSION_PATCH v))))
29 | (<< "Driver Version" (VkPhysicalDeviceProperties-driverVersion props))
30 | (<< "Vendor ID" (VkPhysicalDeviceProperties-vendorID props))
31 | (<< "Device ID" (VkPhysicalDeviceProperties-deviceID props))
32 | (<< "Device Type" (VkPhysicalDeviceProperties-deviceType props))
33 | (<< "Device Name" (let ([array (VkPhysicalDeviceProperties-deviceName props)])
34 | (apply string (sequence->list (sequence-map (λ (ch) (integer->char ch))
35 | (sequence-filter (λ (ch) (> ch 0))
36 | (in-array array)))))))
37 | (<< "Pipeline Cache UUID"
38 | (let ([array (VkPhysicalDeviceProperties-pipelineCacheUUID props)])
39 | (format-uuid (sequence->list (in-array array))))))
40 |
41 | (module+ main
42 | (define instance (createInstance))
43 | (define-values (numDevices pPhysicalDevices)
44 | (get-physical-devices instance))
45 |
46 | (define size (ctype-sizeof _VkPhysicalDeviceProperties))
47 | (define pPropsBuffer (malloc size 'atomic))
48 | (memset pPropsBuffer 0 size)
49 |
50 | (for ([i (in-range numDevices)])
51 | (define pPhysicalDevice (ptr-add pPhysicalDevices i _VkPhysicalDevice))
52 | (vkGetPhysicalDeviceProperties pPhysicalDevice pPropsBuffer)
53 | (define props (ptr-ref pPropsBuffer _VkPhysicalDeviceProperties))
54 | (print-physical-device-properties props))
55 |
56 | (vkDestroyInstance instance #f))
57 |
58 | (define (createInstance)
59 | (define appInfo (make-VkApplicationInfo VK_STRUCTURE_TYPE_APPLICATION_INFO
60 | #f
61 | #"Physical Device Report"
62 | 0
63 | #"examples"
64 | 0
65 | VK_API_VERSION_1_1))
66 |
67 | (define instinfo (make-VkInstanceCreateInfo
68 | VK_STRUCTURE_TYPE_INSTANCE_CREATE_INFO
69 | #f
70 | 0
71 | appInfo
72 | 0
73 | #f
74 | 0
75 | #f))
76 |
77 | (create _VkInstance
78 | (λ (p) (vkCreateInstance instinfo
79 | #f
80 | p))))
81 |
82 | (define (get-physical-devices instance)
83 | (define pDeviceCount (malloc _uint32_t 'atomic))
84 | (vkEnumeratePhysicalDevices instance pDeviceCount #f)
85 | (define num (ptr-ref pDeviceCount _uint32_t))
86 | (when (= num 0)
87 | (error "Expected more than zero physical devices."))
88 | (define size (* num (ctype-sizeof _VkPhysicalDevice)))
89 | (define physical-devices (malloc size 'atomic))
90 | (vkEnumeratePhysicalDevices instance pDeviceCount physical-devices)
91 | (values num
92 | (ptr-ref physical-devices _VkPhysicalDevice 0)))
93 |
--------------------------------------------------------------------------------
/info.rkt:
--------------------------------------------------------------------------------
1 | #lang info
2 | (define collection "vulkan")
3 | (define deps '("base" "compatibility-lib" "txexpr" "graph-lib" "draw-lib" "natural-cli"))
4 | (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib"))
5 | (define scribblings '(("scribblings/vulkan.scrbl" (multi-page))))
6 | (define pkg-desc "Vulkan integration for Racket")
7 | (define version "1.2")
8 | (define pkg-authors '("Sage Gerard"))
9 | (define test-omit-paths '(#rx"unsafe" #rx"examples"))
10 | (define racket-launcher-libraries '("cli/ravk.rkt"))
11 | (define racket-launcher-names '("ravk"))
12 |
--------------------------------------------------------------------------------
/main.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 |
--------------------------------------------------------------------------------
/pre-commit:
--------------------------------------------------------------------------------
1 | #! /bin/bash
2 |
3 | if git rev-parse --verify HEAD >/dev/null 2>&1
4 | then
5 | against=HEAD
6 | else
7 | # Initial commit: diff against an empty tree object
8 | against=$(git hash-object -t tree /dev/null)
9 | fi
10 |
11 | # If you want to allow non-ASCII filenames set this variable to true.
12 | allownonascii=$(git config --bool hooks.allownonascii)
13 |
14 | # Cross platform projects tend to avoid non-ASCII filenames; prevent
15 | # them from being added to the repository. We exploit the fact that the
16 | # printable range starts at the space character and ends with tilde.
17 | if [ "$allownonascii" != "true" ] &&
18 | # Note that the use of brackets around a tr range is ok here, (it's
19 | # even required, for portability to Solaris 10's /usr/bin/tr), since
20 | # the square bracket bytes happen to fall in the designated range.
21 | test $(git diff --cached --name-only --diff-filter=A -z $against |
22 | LC_ALL=C tr -d '[ -~]\0' | wc -c) != 0
23 | then
24 | cat <<\EOF
25 | Error: Attempt to add a non-ASCII file name.
26 |
27 | This can cause problems if you want to work with people on other platforms.
28 |
29 | To be portable it is advisable to rename the file.
30 |
31 | If you know what you are doing you can disable this check using:
32 |
33 | git config hooks.allownonascii true
34 | EOF
35 | exit 1
36 | fi
37 |
38 | # If there are whitespace errors, print the offending file names and fail.
39 | git diff-index --check --cached $against --
40 |
41 | # Run Racket tests
42 | raco test -j 8 --drdr -p vulkan
43 |
--------------------------------------------------------------------------------
/private/assets/hero.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/zyrolasting/racket-vulkan/1e983e921fb41b59994cea0fc0ebd859ec847186/private/assets/hero.png
--------------------------------------------------------------------------------
/private/assets/hero.xcf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/zyrolasting/racket-vulkan/1e983e921fb41b59994cea0fc0ebd859ec847186/private/assets/hero.xcf
--------------------------------------------------------------------------------
/private/c.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ;; This module is responsible for making sense of strings containing
4 | ;; C code, without a parser. Ideally I would use a Clang plugin.
5 |
6 | (provide (all-defined-out))
7 |
8 | (require racket/list
9 | racket/string
10 | "./txexpr.rkt")
11 |
12 | (module+ test
13 | (require rackunit))
14 |
15 | (define (cname str)
16 | (string->symbol (string-append "_" str)))
17 |
18 | (define (infer-pointer-depth characters)
19 | (count (λ (ch) (char=? #\* ch)) characters))
20 |
21 | (define (infer-type undecorated-type characters [lookup #hash()])
22 | (define pointer-depth (infer-pointer-depth characters))
23 |
24 | (define struct?
25 | (and (hash-has-key? lookup undecorated-type)
26 | (category=? "struct" (hash-ref lookup undecorated-type))))
27 |
28 | (define (resolve-alias)
29 | (let ([el (hash-ref lookup undecorated-type)])
30 | (if (attrs-have-key? el 'alias)
31 | (attr-ref el 'alias)
32 | undecorated-type)))
33 |
34 | (if struct?
35 | (cname (case pointer-depth
36 | [(1)
37 | (string-append (resolve-alias)
38 | "-pointer/null")]
39 | [(0) (resolve-alias)]
40 | [else "pointer"]))
41 | (if (> pointer-depth 0)
42 | '_pointer
43 | (cname undecorated-type))))
44 |
45 | (module+ test
46 | (test-equal? "No pointers"
47 | (infer-type "char" '())
48 | '_char)
49 | (test-equal? "Depth = 1"
50 | (infer-type "void" '(#\1 #\* #\f))
51 | '_pointer)
52 | (test-equal? "Depth = 2, mixed chars"
53 | (infer-type "int" '(#\1 #\* #\*))
54 | '_pointer)
55 | (test-equal? "Special case: Struct name"
56 | (infer-type "ST" '() '#hash(("ST" . (type ((category "struct"))))))
57 | '_ST)
58 | (test-equal? "Special case: Struct name, Depth = 1"
59 | (infer-type "ST" '(#\*) '#hash(("ST" . (type ((category "struct"))))))
60 | '_ST-pointer/null)
61 | (test-equal? "Special case: Struct name, Depth = 2"
62 | (infer-type "ST" '(#\* #\*) '#hash(("ST" . (type ((category "struct"))))))
63 | '_pointer))
64 |
--------------------------------------------------------------------------------
/private/generate/api-constants.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require racket/list
5 | "./shared.rkt")
6 |
7 | ;; Declare all Vulkan API constants as Racket code.
8 | (define (in-fragment registry [config #hash()])
9 | (in-generator
10 | (yield (generate-define-constant-signature registry "VK_HEADER_VERSION"))
11 | (yield (generate-define-constant-signature registry "VK_NULL_HANDLE"))
12 | (yield* (generate-consts-from-enums-elements registry))))
13 |
14 |
15 | ;; Input: #define X 10
16 | ;; Output: (define X 10)
17 | ;; Assumes the value is always a decimal number.
18 | (define (generate-define-constant-signature registry target-name)
19 | `(define
20 | ,(string->symbol target-name)
21 | ,(string->number
22 | (regexp-replace*
23 | #px"\\D+"
24 | (shrink-wrap-cdata
25 | (findf-txexpr (findf-txexpr registry
26 | (λ (x) (tag=? 'types x)))
27 | (λ (x)
28 | (and (tag=? 'type x)
29 | (equal? (get-type-name x)
30 | target-name)))))
31 | ""))))
32 |
33 |
34 | ;; Turns representing Vulkan API constants into Racket code.
35 | ;; The predicate derived from https://www.khronos.org/registry/vulkan/specs/1.1/registry.html#tag-enums
36 | ;; says that elements without a `type` attribute represent
37 | ;; API constants. But those don't include extension constants,
38 | ;; so we have to grab those separately.
39 | (define (generate-consts-from-enums-elements registry)
40 | (in-generator
41 | (for ([enums-element (get-all-enums-elements registry)])
42 | (unless (attrs-have-key? enums-element 'type)
43 | (yield* (generate-consts-signature enums-element))))))
44 |
45 | (define (get-all-enums-elements registry)
46 | (append (find-all-by-tag 'enums registry)
47 | (list (find-extension-constants registry))))
48 |
49 | ;; Vulkan extensions can declare their own constants.
50 | ;; Yank them out as elements so we can process
51 | ;; them as such.
52 | (define (find-extension-constants registry)
53 | (define (accum source fetch)
54 | (foldl (λ (x res)
55 | (define matches (fetch x))
56 | (if matches
57 | (append res matches)
58 | res))
59 | '()
60 | source))
61 |
62 | ; The enumerants are inside elements.
63 | (define require-elements
64 | (accum
65 | (find-all-by-tag 'extension registry)
66 | (λ (x) (find-all-by-tag 'require x))))
67 | (define enum-elements
68 | (accum
69 | require-elements
70 | (λ (x) (find-all-by-tag 'enum x))))
71 |
72 | ; Enumerants that don't extend a C enum type are API constants.
73 | `(enums . ,(filter (λ (x) (and (attrs-have-key? x 'value)
74 | (not (attrs-have-key? x 'extends))))
75 | enum-elements)))
76 |
77 |
78 | ;; Convert an element representing API constants into Racket code.
79 | (define (generate-consts-signature enums-xexpr)
80 | (in-generator
81 | (define enumerant-list (filter (λ (x) (tag=? 'enum x))
82 | (get-elements enums-xexpr)))
83 | (for ([enumerant enumerant-list])
84 | (yield `(define ,(string->symbol (attr-ref enumerant 'name))
85 | ,(if (attrs-have-key? enumerant 'alias)
86 | (string->symbol (attr-ref enumerant 'alias))
87 | (extract-value enumerant)))))))
88 |
89 | ;; Creates a Racket value from a Vulkan element representing
90 | ;; an API constant.
91 | (define (extract-value enumerant)
92 | (define value (attr-ref enumerant 'value))
93 | (if (string-contains? value "\"")
94 | (string->bytes/utf-8 (string-replace value "\"" ""))
95 | (let ([num-expr (c-numeric-lit->number value)])
96 | (if (equal? (attr-ref enumerant 'dir #f) "-1")
97 | `(* -1 ,num-expr)
98 | num-expr))))
99 |
100 |
101 | ;; A limited converter from C numeric literals to a Racket number.
102 | ;;
103 | ;; Assumptions:
104 | ;; 1. If "~" is in the string, it is a complement of 0.
105 | ;; 2. All other values equals the decimal value of the first
106 | ;; contiguous sequence of digits in the string.
107 | (define (c-numeric-lit->number c-num-lit-string)
108 | (if (string-contains? c-num-lit-string "~")
109 | (compute-~0-declaration c-num-lit-string)
110 | (string->number (car (regexp-match* #px"\\d+"
111 | c-num-lit-string)))))
112 |
113 |
114 | ;; This procedure is a tiny, limited parser for a subset of C numeric
115 | ;; literals. Namely, complements of 0. The returned quasiquoted value
116 | ;; expands such that (ctype-sizeof) runs on the client's system, but
117 | ;; the "LL" check expands while control is in this procedure. This is
118 | ;; to make sure the client's system uses its own word size.
119 | (define (compute-~0-declaration literal)
120 | ; Extract subtraction operand
121 | (define sub-op/match (regexp-match* #px"-\\d" literal))
122 | (define sub-op (if (empty? sub-op/match)
123 | 0
124 | (abs (string->number (car sub-op/match)))))
125 |
126 | `(- (integer-bytes->integer
127 | (make-bytes
128 | (ctype-sizeof
129 | ,(cond
130 | [(string-contains? literal "LL") '_llong]
131 | [(string-contains? literal "L")
132 | ;; this case doesn't currently occur, but maybe it will in the future?
133 | '_long]
134 | [else '_int]))
135 | 255)
136 | ,(not (string-contains? literal "U")))
137 | ,sub-op))
138 |
--------------------------------------------------------------------------------
/private/generate/api-constants.test.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 |
4 | (module+ test
5 | (require racket/sequence
6 | rackunit
7 | "./api-constants.rkt")
8 |
9 | (test-equal? "(find-extension-constants)"
10 | (find-extension-constants
11 | '(root (extension "\n "
12 | (require (enum ((extends "A") (name "B")))
13 | (enum ((name "X") (value "1")))))))
14 | '(enums (enum ((name "X") (value "1")))))
15 |
16 | (test-equal? "(generate-consts-signature)"
17 | (sequence->list
18 | (generate-consts-signature
19 | '(enums (enum ((value "(~0U)") (name "A")))
20 | (enum ((value "(~0ULL-2)") (name "B")))
21 | (enum ((value "(~0L)") (name "C")))
22 | (enum ((value "256") (name "D")))
23 | (enum ((value "(~0UL)") (dir "-1") (name "N")))
24 | (enum ((name "E") (alias "C"))))))
25 | '((define A
26 | (- (integer-bytes->integer (make-bytes (ctype-sizeof _long) 255) #t)
27 | 0))
28 | (define B
29 | (- (integer-bytes->integer (make-bytes (ctype-sizeof _llong) 255) #t)
30 | 2))
31 | (define C
32 | (- (integer-bytes->integer (make-bytes (ctype-sizeof _long) 255) #f)
33 | 0))
34 | (define D 256)
35 | (define N
36 | (* -1
37 | (- (integer-bytes->integer (make-bytes (ctype-sizeof _long) 255) #t)
38 | 0)))
39 | (define E C))))
40 |
--------------------------------------------------------------------------------
/private/generate/ctypes.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ; -------------------------------------------------------------------
4 | ; This module generates the most basic, platform-agnostic C type
5 | ; declarations that appear in vk.xml.
6 |
7 | (provide (all-defined-out))
8 | (require "./shared.rkt")
9 |
10 | (define (in-fragment registry [config #hash()])
11 | (in-generator
12 | (for ([declaration (find-ctype-declarations registry)])
13 | (yield (generate-ctype-signature declaration)))))
14 |
15 |
16 | ; The keys are C type names as they appear in vk.xml. The values are
17 | ; what the identifiers should be in Racket, without the leading
18 | ; underscore.
19 | (define name=>existing
20 | #hash(("char" . "sbyte")
21 | ("void" . "void")
22 | ("uint32_t" . "uint32")
23 | ("float" . "float")
24 | ("double" . "double")
25 | ("uint8_t" . "uint8")
26 | ("uint16_t" . "uint16")
27 | ("uint32_t" . "uint32")
28 | ("uint64_t" . "uint64")
29 | ("int32_t" . "int32")
30 | ("int64_t" . "int64")
31 | ("size_t" . "size")))
32 |
33 |
34 | (define (find-ctype-declarations registry)
35 | (define (already-in-racket? x)
36 | (member (cname (get-type-name x))
37 | '(_void _float _double _int)))
38 |
39 | ; designates C types.
40 | ; Keep only those that ffi/unsafe does not already
41 | ; provide.
42 | (filter
43 | (λ (x)
44 | (and (equal? (attr-ref x 'requires "") "vk_platform")
45 | (not (already-in-racket? x))))
46 | (get-type-elements registry)))
47 |
48 |
49 | (define (generate-ctype-signature type-xexpr)
50 | (define registry-type-name (get-type-name type-xexpr))
51 | (define racket-id (cname registry-type-name))
52 | (define type-id
53 | (if (hash-has-key? name=>existing registry-type-name)
54 | (hash-ref name=>existing registry-type-name)
55 | ; The _t replacement occurs because Racket C numeric types exclude them,
56 | ; and Racket already has bindings for _size, _uint8, etc.
57 | (string-replace registry-type-name
58 | "_t"
59 | "")))
60 |
61 | `(define ,racket-id ,(cname type-id)))
62 |
--------------------------------------------------------------------------------
/private/generate/ctypes.test.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (module+ test
4 | (require rackunit
5 | "ctypes.rkt")
6 | (test-equal? "Generate ctype without _t"
7 | (generate-ctype-signature '(type ((category "ctype") (name "void"))))
8 | '(define _void _void))
9 | (test-equal? "Generate ctype signature with _t"
10 | (generate-ctype-signature '(type ((category "ctype") (name "uint32_t"))))
11 | '(define _uint32_t _uint32)))
12 |
--------------------------------------------------------------------------------
/private/generate/defines.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ;; The "define" category may contain C code of several meanings for
4 | ;; our purposes. We cannot easily deal with the function-style C macros,
5 | ;; but we do want the ones that give us simple bindings. This module
6 | ;; generates those.
7 |
8 | (provide (all-defined-out))
9 | (require racket/string
10 | "./shared.rkt")
11 |
12 | (define (in-fragment registry [config #hash()])
13 | (in-generator
14 | (for ([element (get-type-by-category "define" registry)])
15 | (unless (is-c-macro? element)
16 | (yield (generate-define-signature element))))))
17 |
18 | (define (generate-define-signature type-xexpr)
19 | (define name (get-type-name type-xexpr))
20 | `(define ,(cname name) ',(string->symbol name)))
21 |
22 | ;; The "define" category includes both C macros and C type
23 | ;; declarations presented as preprocessor directives. This predicate
24 | ;; should distinguish between the two.
25 | (define (is-c-macro? type-xexpr)
26 | (define name (get-type-name type-xexpr))
27 | (define category (attr-ref type-xexpr 'category ""))
28 | (and (string-prefix? name "VK_")
29 | (equal? (string-upcase name)
30 | name)))
31 |
--------------------------------------------------------------------------------
/private/generate/defines.test.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (module+ test
4 | (require rackunit
5 | "./defines.rkt")
6 |
7 | (test-equal? "(generate-define-signature)"
8 | (generate-define-signature '(type ((name "VkDeviceAddress"))))
9 | '(define _VkDeviceAddress 'VkDeviceAddress)))
10 |
--------------------------------------------------------------------------------
/private/generate/handles.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ;; Generates Racket code to declare handle types. Handles are just
4 | ;; pointers to forward-declared structs with private definitions. We
5 | ;; use symbols to represent them on the Racket side.
6 |
7 | (provide (all-defined-out))
8 | (require "./shared.rkt")
9 |
10 | (define (in-fragment registry [config #hash()])
11 | (in-generator
12 | (for ([element (get-type-by-category "handle" registry)])
13 | (yield (generate-handle-signature element)))))
14 |
15 | (define (generate-handle-signature handle-xexpr)
16 | (define name (get-type-name handle-xexpr))
17 | `(define ,(cname name) (_cpointer/null ',(string->symbol (string-append name "_T")))))
18 |
--------------------------------------------------------------------------------
/private/generate/handles.test.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (module+ test
4 | (require rackunit
5 | "./handles.rkt")
6 |
7 | (test-equal? "(generate-handle-signature)"
8 | (generate-handle-signature '(type ((category "handle"))
9 | "MAKE_HANDLE(" (name "VkDevice") ")"))
10 | '(define _VkDevice (_cpointer/null 'VkDevice_T))))
11 |
--------------------------------------------------------------------------------
/private/generate/interdependent.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require racket/hash
5 | racket/list
6 | racket/set
7 | racket/string
8 | graph
9 | "./shared.rkt")
10 |
11 | (define (in-fragment registry [config #hash()])
12 | (in-generator
13 | (define ordered (curate-registry registry))
14 | (define lookup (get-type-lookup ordered))
15 |
16 | (define category=>proc
17 | `#hash(("enum" . ,generate-enum-signature)
18 | ("bitmask" . ,generate-bitmask-signature)
19 | ("funcpointer" . ,generate-funcpointer-signature)
20 | ("struct" . ,generate-struct-signature)
21 | ("union" . ,generate-union-signature)
22 | ("command" . ,generate-command-signature)))
23 |
24 | (for ([type (in-list ordered)])
25 | (define category (attr-ref type 'category ""))
26 | (define alias (attr-ref type 'alias #f))
27 | (define make-datum (hash-ref category=>proc category #f))
28 | (when make-datum
29 | (yield (if alias
30 | (let ([namer (if (tag=? 'command type) string->symbol cname)])
31 | `(define ,(namer (get-type-name type)) ,(namer alias)))
32 | (make-datum type registry lookup config)))))))
33 |
34 | (define collect-enums
35 | (memoizer (λ (registry)
36 | (find-all-by-tag 'enums registry))))
37 |
38 | (define collect-named-enums
39 | (memoizer (λ (registry)
40 | (foldl (λ (x h) (if (attrs-have-key? x 'name)
41 | (hash-set h (attr-ref x 'name) x)
42 | h))
43 | #hash()
44 | (collect-enums registry)))))
45 |
46 |
47 | ;; Unfortunately the registry makes no guarentee that types will appear
48 | ;; in a specific order. If you simply blast the types out in the order
49 | ;; given to you in vk.xml, Racket will complain of unbound identifiers.
50 | ;;
51 | ;; That, and the `requires` attribute is not useful for modeling type
52 | ;; dependencies. The only real option is to build a directed graph of
53 | ;; name references and artificially discard recursive type references.
54 | ;; The result should be a DAG, but later parts of the code has to exercise
55 | ;; caution re: forward declarations and recursive definitions.
56 | (define (sort-types types)
57 | ;; Build a lookup so we can work with type names alone.
58 | (define lookup (get-type-lookup types))
59 | (define (resolve name)
60 | (hash-ref lookup name))
61 |
62 | (define (get-custom-type-dependencies tx)
63 | (map (λ (x) (get-text-in-tagged-child 'type x))
64 | (find-all-by-tag 'member tx)))
65 |
66 | (define (get-funcpointer-dependencies tx)
67 | (map shrink-wrap-cdata
68 | (filter (λ (x) (tag=? 'type x))
69 | (get-elements tx))))
70 |
71 | ;; Return a list of dependent types.
72 | (define (get-type-dependencies type-xexpr)
73 | (define dependent-name (get-type-name type-xexpr))
74 | (define alias (attr-ref type-xexpr 'alias #f))
75 | (define get-dependencies (case (attr-ref type-xexpr 'category "")
76 | [("struct" "union") get-custom-type-dependencies]
77 | [("funcpointer") get-funcpointer-dependencies]
78 | [else (λ _ '())]))
79 |
80 | ; Exclude recursive type declarations and names that do not
81 | ; appear as declared types in the registry (Rare).
82 | (if alias
83 | (list alias)
84 | (filter-map
85 | (λ (dependency-name)
86 | (and (hash-has-key? lookup dependency-name)
87 | (not (equal? dependent-name dependency-name))
88 | dependency-name))
89 | (get-dependencies type-xexpr))))
90 |
91 | ;; Used for a fold that builds directed edges in the dependency graph.
92 | ;; I use a mock "ROOT" vertex to make sure elements with no dependencies
93 | ;; appear in the graph.
94 | (define (accumulate-dependencies xexpr edges)
95 | (define dependent-type (get-type-name xexpr))
96 | (append (map (λ (dependency-typename)
97 | (list dependency-typename
98 | dependent-type))
99 | (cons "ROOT" (get-type-dependencies xexpr)))
100 | edges))
101 |
102 | ; Place the most dependent types last.
103 | (define most-to-least-responsible/names
104 | (remove "ROOT"
105 | (tsort (directed-graph
106 | (foldl accumulate-dependencies '() types)))))
107 |
108 | ; Use lookup to transform names back to elements, and tack
109 | ; the aliased elements back on.
110 | (map resolve most-to-least-responsible/names))
111 |
112 | ;; Just toss a category on elements for consistency.
113 | ;; Keeps the logic in generate-bindings.rkt easier to think about.
114 | (define (categorize-commands commands-list)
115 | (filter-map (λ (x)
116 | (and (tag=? 'command x)
117 | (attr-set x 'category "command")))
118 | commands-list))
119 |
120 | ; Return declaration elements in sorted groups.
121 | (define (curate-registry registry)
122 | (define curated-declarations
123 | (append (sort-types (get-tagged-children (find-first-by-tag 'types registry)))
124 | (categorize-commands (get-tagged-children (find-first-by-tag 'commands registry)))))
125 |
126 | (define interdependent-categories '("struct" "union" "funcpointer" "command" "bitmask" "enum"))
127 | (filter (λ (x) (member (attr-ref x 'category "")
128 | interdependent-categories))
129 | curated-declarations))
130 |
131 |
132 | ;; ------------------------------------------------
133 | ;; C unions correspond to
134 |
135 | (define (generate-member-signature/union member-xexpr)
136 | (define undecorated-type (snatch-cdata 'type member-xexpr))
137 | (define cdata (get-all-cdata member-xexpr))
138 | (define characters (string->list cdata))
139 | (define array-size-match (regexp-match #px"\\[([^\\]]+)\\]" cdata))
140 | (define as-cname (cname undecorated-type))
141 | (define ctype (if (eq? as-cname '_void) '_pointer as-cname))
142 | (if array-size-match
143 | `(_list-struct . ,(build-list (string->number (cadr array-size-match))
144 | (λ _ ctype)))
145 | `(_list-struct ,ctype)))
146 |
147 | (define (generate-union-signature union-xexpr . _)
148 | (define members (get-elements-of-tag 'member union-xexpr))
149 | (define name (get-type-name union-xexpr))
150 | `(begin
151 | (define ,(cname name)
152 | (_union
153 | . ,(map generate-member-signature/union
154 | members)))
155 | . ,(map
156 | (λ (x ordinal)
157 | `(define (,(string->symbol (string-append name
158 | "-"
159 | (shrink-wrap-cdata (find-first-by-tag 'name x)))) u)
160 | (union-ref u ,ordinal)))
161 | members
162 | (range (length members)))))
163 |
164 | ;; ------------------------------------------------
165 | ;; C structs correspond to
166 |
167 | (define (generate-struct-signature struct-xexpr [registry #f] [lookup #hash()] [config #hash()])
168 | (define struct-name (get-type-name struct-xexpr))
169 | (define (generate-member-signature member-xexpr)
170 | (define name (snatch-cdata 'name member-xexpr))
171 | (define enum (find-first-by-tag 'enum member-xexpr))
172 | (define numeric-length (regexp-match #px"\\[(\\d+)\\]" (shrink-wrap-cdata member-xexpr)))
173 | (define undecorated-type (snatch-cdata 'type member-xexpr))
174 | (define characters (string->list (shrink-wrap-cdata member-xexpr)))
175 | (define inferred-type (infer-type (if (equal? undecorated-type struct-name)
176 | "void"
177 | undecorated-type)
178 | characters
179 | lookup))
180 |
181 | (define type (if enum
182 | `(_array ,inferred-type ,(string->symbol (shrink-wrap-cdata enum)))
183 | (if numeric-length
184 | `(_array ,inferred-type ,(string->number (cadr numeric-length)))
185 | inferred-type)))
186 |
187 | `(,(string->symbol name) ,type))
188 |
189 | `(define-cstruct ,(cname struct-name)
190 | . (,(map generate-member-signature
191 | (get-elements-of-tag 'member
192 | struct-xexpr)))))
193 |
194 |
195 | ;; ------------------------------------------------------------------
196 | ;; Enumerations are related by and elements. Some
197 | ;; elements are a list of #defines. Others are actual C enums.
198 | ;; This is the case that generates actual C enums.
199 | (define collect-extensions-by-enum-name
200 | (memoizer (λ (registry)
201 | (foldl (λ (extension result)
202 | (foldl (λ (enumerant collecting-enumerants)
203 | (hash-set collecting-enumerants
204 | (attr-ref enumerant 'name)
205 | extension))
206 | result
207 | (or (find-all-by-tag 'enum extension)
208 | '())))
209 | #hash()
210 | (find-all-by-tag 'extension registry)))))
211 |
212 |
213 | (define (collect-enumerants-by-name where)
214 | (foldl (λ (enum result)
215 | (if (attrs-have-key? enum 'name)
216 | (hash-set result (attr-ref enum 'name) enum)
217 | result))
218 | #hash()
219 | (find-all-by-tag 'enum where)))
220 |
221 | (define collect-enumerants-by-name/all
222 | (memoizer collect-enumerants-by-name))
223 | (define collect-enumerants-by-name/core
224 | (memoizer (λ (registry)
225 | (collect-enumerants-by-name
226 | (find-first-by-tag 'enums registry)))))
227 | (define collect-enumerants-by-name/features
228 | (memoizer (λ (registry)
229 | (define hashes (map collect-enumerants-by-name (find-all-by-tag 'feature registry)))
230 | (if (empty? hashes)
231 | #hash()
232 | (apply hash-union hashes)))))
233 |
234 | (define collect-enumerant-name-counts
235 | (memoizer (λ (registry)
236 | (foldl (λ (enum result)
237 | (if (attrs-have-key? enum 'name)
238 | (hash-set result
239 | (attr-ref enum 'name)
240 | (add1 (hash-ref result (attr-ref enum 'name) 0)))
241 | result))
242 | #hash()
243 | (find-all-by-tag 'enum registry)))))
244 |
245 | (define collect-enumerant-relationships
246 | (memoizer
247 | (λ (registry)
248 | (foldl (λ (x res)
249 | (hash-set res
250 | (attr-ref x 'extends)
251 | (cons x (hash-ref res (attr-ref x 'extends) '()))))
252 | #hash()
253 | (or (findf*-txexpr
254 | registry
255 | (λ (x) (and (tag=? 'enum x)
256 | (attrs-have-key? x 'extends))))
257 | '())))))
258 |
259 |
260 | (define (generate-enum-signature enum-xexpr registry [lookup #hash()] [config #hash()])
261 | (define name (get-type-name enum-xexpr))
262 | (define extension-lookup (collect-extensions-by-enum-name registry))
263 | (define enum-lookup (collect-enumerants-by-name/all registry))
264 | (define enum-lookup/core (collect-enumerants-by-name/core registry))
265 | (define enum-lookup/features (collect-enumerants-by-name/features registry))
266 | (define relationship-lookup (collect-enumerant-relationships registry))
267 | (define name-counts (collect-enumerant-name-counts registry))
268 |
269 | (define (belongs-to-extension? name)
270 | (hash-has-key? extension-lookup name))
271 |
272 | ; Some enumerants have values computed in terms of enum ranges in other extensions.
273 | ; The spec covers how to compute these values.
274 | ; https://www.khronos.org/registry/vulkan/specs/1.1/styleguide.html#_assigning_extension_token_values
275 | (define (find-extension-relative-value enumerant)
276 | ; In English: First try to get the "extnumber" attribute value on
277 | ; the enumerant. Failing that, find the element that
278 | ; has the enumerant as a descendent and grab its "number"
279 | ; attribute value
280 | (define ext-number
281 | (string->number
282 | (attr-ref enumerant 'extnumber
283 | (λ _ (attr-ref
284 | (hash-ref extension-lookup (attr-ref enumerant 'name))
285 | 'number)))))
286 |
287 | (define base-value 1000000000)
288 | (define range-size 1000)
289 | (define offset (string->number (attr-ref enumerant 'offset)))
290 | (define sign (if (equal? "-" (attr-ref enumerant 'dir #f)) -1 1))
291 | (* sign (+ base-value (* (- ext-number 1) range-size) offset)))
292 |
293 | ; Empty enums are possible.
294 | ; https://github.com/KhronosGroup/Vulkan-Docs/issues/1060
295 | (define enum-decl (hash-ref (collect-named-enums registry)
296 | name
297 | (λ _ '(enums))))
298 |
299 | ; Some enumerants are an alias for another enumerant.
300 | (define (resolve-alias enumerant)
301 | (define alias (attr-ref enumerant 'alias))
302 | (attr-set
303 | (hash-ref enum-lookup alias)
304 | 'name
305 | (attr-ref enumerant 'name)))
306 |
307 | ; Pull out the intended (assumed numerical) value
308 | ; from the enumerant.
309 | (define (extract-value enumerant)
310 | (if (attrs-have-key? enumerant 'alias)
311 | (extract-value (resolve-alias enumerant))
312 | (if (attrs-have-key? enumerant 'offset)
313 | (find-extension-relative-value enumerant)
314 | (let ([n (if (attrs-have-key? enumerant 'bitpos)
315 | (arithmetic-shift 1 (string->number (attr-ref enumerant 'bitpos)))
316 | (let ([val (attr-ref enumerant 'value)])
317 | (if (string-prefix? val "0x")
318 | (string->number (string-replace val "0x" "") 16)
319 | (string->number val))))])
320 | (if (equal? "-" (attr-ref enumerant 'dir #f))
321 | (* -1 n)
322 | n)))))
323 |
324 | ; Find the enumerants that extend this type.
325 | (define extensions
326 | (hash-ref relationship-lookup
327 | name
328 | (λ _ '())))
329 |
330 | ; HACK: For now, ignore the extension enums that duplicate definitions.
331 | (define deduped
332 | (filter
333 | (λ (x)
334 | (<= (hash-ref name-counts (attr-ref x 'name) 0)
335 | 1))
336 | extensions))
337 |
338 | (define enumerants (append
339 | (filter (λ (x) (tag=? 'enum x))
340 | (get-elements enum-decl))
341 | deduped))
342 |
343 | ; Pair up enumerant names and values.
344 | (define pairs (reverse (map (λ (x) (cons (attr-ref x 'name)
345 | (extract-value x)))
346 | enumerants)))
347 |
348 | ; To be nice to Racketeers, let's give them easy flags when
349 | ; using Vulkan so they don't have to OR things together themselves.
350 | (define ctype (if (equal? "bitmask" (attr-ref enum-decl 'type ""))
351 | '_bitmask
352 | '_enum))
353 |
354 | ; _enum or _bitmask need a basetype to match how the values are used.
355 | ; https://docs.racket-lang.org/foreign/Enumerations_and_Masks.html?q=_enum#%28def._%28%28lib._ffi%2Funsafe..rkt%29.__enum%29%29
356 | (define basetype
357 | (if (equal? ctype '_enum)
358 | (if (ormap (λ (pair) (< (cdr pair) 0)) pairs)
359 | '_fixint
360 | '_ufixint)
361 | '_uint))
362 |
363 | (define declared-enumerants
364 | (for/list ([enumerant (in-list (reverse pairs))])
365 | `(define ,(string->symbol (car enumerant)) ,(cdr enumerant))))
366 |
367 | (if (hash-ref config 'enable-symbolic-enums #f)
368 | `(begin
369 | (define ,(cname name)
370 | (,ctype
371 | ',(for/fold ([decls '()])
372 | ([enumerant (in-list pairs)])
373 | ; The ctype declaration assumes a list of form (name0 = val0 name1 = val1 ...)
374 | (define w/value (cons (cdr enumerant) decls))
375 | (define w/= (cons '= w/value))
376 | (define w/all (cons (string->symbol (car enumerant)) w/=))
377 | w/all)
378 | ,basetype))
379 | . ,declared-enumerants)
380 | `(begin
381 | (define ,(cname name) ,basetype)
382 | . ,declared-enumerants)))
383 |
384 |
385 | ;; ------------------------------------------------------------------
386 | ; is just a C type declaration that happens
387 | ; to contain a typedef. Declaring _bitmask in Racket actually happens
388 | ; as part of processing enums.
389 |
390 | (define (generate-bitmask-signature bitmask-xexpr . _)
391 | (define alias (attr-ref bitmask-xexpr 'alias #f))
392 | `(define ,(cname (get-type-name bitmask-xexpr))
393 | ,(cname (or alias
394 | (snatch-cdata 'type
395 | bitmask-xexpr
396 | #:children-only? #t)))))
397 |
398 |
399 | ;; ------------------------------------------------------------------
400 | ;; hurts a little because parameter
401 | ;; type tags are floating in a soup of C code. I assume that only
402 | ;; pointer indirection matters and check for '*' in the next sibling
403 | ;; strings after the parameter types. The return type is not even
404 | ;; in a tag at all, so I have a different approach to deduce it.
405 |
406 | (define (generate-funcpointer-signature funcpointer-xexpr [registry #f] [lookup #hash()] [config #hash()])
407 | (define name (get-type-name funcpointer-xexpr))
408 | (define text-signature (get-all-cdata funcpointer-xexpr))
409 |
410 | ; Deduce the formal parameter types
411 | (define children (get-elements funcpointer-xexpr))
412 | (define parameter-type-elements (filter (λ (x) (tag=? 'type x)) children))
413 | (define adjacent-cdata (map (λ (type-xexpr)
414 | (list-ref children
415 | (add1 (index-of children type-xexpr))))
416 | parameter-type-elements))
417 |
418 | (define parameter-types (map (λ (type-xexpr decl)
419 | (infer-type (shrink-wrap-cdata type-xexpr)
420 | (string->list decl)
421 | lookup))
422 | parameter-type-elements
423 | adjacent-cdata))
424 |
425 | ; Deduce the return type
426 | (define return-signature (cadr (regexp-match #px"typedef ([^\\(]+)" text-signature)))
427 | (define undecorated-return-type (regexp-replace* #px"[\\s\\*\\[\\]]" return-signature ""))
428 | (define return-type (infer-type undecorated-return-type
429 | (string->list return-signature)
430 | lookup))
431 |
432 | `(define ,(cname name)
433 | (_fun ,@parameter-types
434 | ->
435 | ,return-type)))
436 |
437 |
438 | ;; ------------------------------------------------------------------
439 | ;; All that stuff above was just the data. Now let's talk functions.
440 |
441 |
442 | ;; The return value of a function in context of the FFI is a bit tricky.
443 | ;; We want to capture pass-by-reference values returned to Racket, and
444 | ;; incorporate return code checking. This procedure generates code for
445 | ;; use as a `maybe-wrapper` in the `_fun` form. This assumes that `r`
446 | ;; is the identifier bound to the function's normal return value.
447 | (define (generate-maybe-wrapper vkResult? who)
448 | (if (not vkResult?)
449 | null
450 | `(-> (check-vkResult r ',who))))
451 |
452 |
453 | (define (generate-type-spec param)
454 | (define c-code (shrink-wrap-cdata param))
455 | (define ctype/text (get-text-in-tagged-child 'type param))
456 | (define pointer? (string-contains? c-code "*"))
457 |
458 | (if pointer?
459 | '_pointer
460 | (cname ctype/text)))
461 |
462 |
463 | (define (generate-command-signature command-xexpr [registry #f] [lookup #hash()] [config #hash()])
464 | (define children (filter (λ (x) (and (txexpr? x)
465 | (member (get-tag x) '(param proto))))
466 | (get-elements command-xexpr)))
467 |
468 | ; always comes first.
469 | ; https://www.khronos.org/registry/vulkan/specs/1.1/registry.html#_contents_of_command_tags
470 | (define proto (car children))
471 | (define id (string->symbol (get-text-in-tagged-child 'name proto)))
472 | (define undecorated-return (get-text-in-tagged-child 'type proto))
473 | (define characters (string->list (shrink-wrap-cdata proto)))
474 | (define ret (infer-type undecorated-return
475 | characters
476 | lookup))
477 |
478 | (define param-elements (cdr children))
479 | (define type-specs (map generate-type-spec param-elements))
480 | (define auto-check-return-code? (and (equal? undecorated-return "VkResult")
481 | (hash-ref config 'enable-auto-check-vkresult #f)))
482 |
483 | `(define-vulkan ,id
484 | (_fun ,@type-specs
485 | ->
486 | ,(if (equal? ret '_void)
487 | ret
488 | `(r : ,ret))
489 | . ,(generate-maybe-wrapper auto-check-return-code?
490 | id))))
491 |
--------------------------------------------------------------------------------
/private/generate/interdependent.test.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (module+ test
4 | (require rackunit
5 | racket/list
6 | "./shared.rkt"
7 | "./interdependent.rkt")
8 |
9 | (test-case "(generate-union-signature)"
10 | (define example-union-xexpr
11 | '(type ((category "union") (name "VkClearColorValue"))
12 | (member (type "float")
13 | (name "float32")
14 | "[4]")
15 | (member (type "int32_t")
16 | (name "int32")
17 | "[4]")
18 | (member (type "uint32_t")
19 | (name "uint32")
20 | "[4]")))
21 | (check-equal?
22 | (generate-union-signature example-union-xexpr)
23 | '(begin
24 | (define _VkClearColorValue
25 | (_union (_list-struct _float _float _float _float)
26 | (_list-struct _int32_t _int32_t _int32_t _int32_t)
27 | (_list-struct _uint32_t _uint32_t _uint32_t _uint32_t)))
28 | (define (VkClearColorValue-float32 u)
29 | (union-ref u 0))
30 | (define (VkClearColorValue-int32 u)
31 | (union-ref u 1))
32 | (define (VkClearColorValue-uint32 u)
33 | (union-ref u 2)))))
34 |
35 |
36 | (test-case "(generate-struct-signature)"
37 | ; Faithful parse of vk.xml fragment. Do not modify.
38 | (define example-struct-xexpr
39 | '(type ((category "struct")
40 | (name "VkDeviceCreateInfo"))
41 | "\n "
42 | (member ((values "VK_STRUCTURE_TYPE_DEVICE_CREATE_INFO"))
43 | (type () "VkStructureType") " "
44 | (name () "sType"))
45 | "\n "
46 | (member ()
47 | "const "
48 | (type () "void")
49 | "* "
50 | (name () "pNext"))
51 | "\n "
52 | (member ((optional "true"))
53 | (type () "VkDeviceCreateFlags")
54 | " "
55 | (name () "flags"))
56 | "\n "
57 | (member ()
58 | (type () "uint32_t")
59 | " "
60 | (name () "queueCreateInfoCount"))
61 | "\n "
62 | (member ((len "queueCreateInfoCount"))
63 | "const "
64 | (type () "VkDeviceQueueCreateInfo")
65 | "* " (name () "pQueueCreateInfos"))
66 | "\n "
67 | (member ((optional "true"))
68 | (type () "uint32_t")
69 | " "
70 | (name () "enabledLayerCount"))
71 | "\n "
72 | (member ((len "enabledLayerCount,null-terminated"))
73 | "const "
74 | (type () "char")
75 | "* const* "
76 | (name () "ppEnabledLayerNames")
77 | (comment () "Ordered list of layer names to be enabled"))
78 | "\n "
79 | (member ((optional "true"))
80 | (type () "uint32_t")
81 | " "
82 | (name () "enabledExtensionCount"))
83 | "\n "
84 | (member ((len "enabledExtensionCount,null-terminated"))
85 | "const "
86 | (type () "char")
87 | "* const* "
88 | (name () "ppEnabledExtensionNames"))
89 | "\n "
90 | (member ((optional "true"))
91 | "const "
92 | (type () "VkPhysicalDeviceFeatures")
93 | "* "
94 | (name () "pEnabledFeatures"))
95 | "\n"))
96 |
97 | (check-equal?
98 | (generate-struct-signature example-struct-xexpr)
99 | `(define-cstruct _VkDeviceCreateInfo
100 | ((sType _VkStructureType)
101 | (pNext _pointer)
102 | (flags _VkDeviceCreateFlags)
103 | (queueCreateInfoCount _uint32_t)
104 | (pQueueCreateInfos _pointer)
105 | (enabledLayerCount _uint32_t)
106 | (ppEnabledLayerNames _pointer)
107 | (enabledExtensionCount _uint32_t)
108 | (ppEnabledExtensionNames _pointer)
109 | (pEnabledFeatures _pointer))))
110 |
111 |
112 | (test-equal? "(generate-struct-signature): circular"
113 | (generate-struct-signature
114 | '(type ((category "struct")
115 | (name "C"))
116 | (member (type "C") "* " (name "pNext"))))
117 | `(define-cstruct _C
118 | ((pNext _pointer)))))
119 |
120 | (test-case "(generate-enum-signature)"
121 | (define enum-registry '(registry
122 | (enums ((name "VkShaderStageFlagBits") (type "bitmask"))
123 | (enum ((bitpos "0") (name "VK_SHADER_STAGE_VERTEX_BIT")))
124 | (enum ((bitpos "1") (name "VK_SHADER_STAGE_TESSELLATION_CONTROL_BIT")))
125 | (enum ((bitpos "2") (name "VK_SHADER_STAGE_TESSELLATION_EVALUATION_BIT")))
126 | (enum ((bitpos "3") (name "VK_SHADER_STAGE_GEOMETRY_BIT")))
127 | (enum ((bitpos "4") (name "VK_SHADER_STAGE_FRAGMENT_BIT")))
128 | (enum ((bitpos "5") (name "VK_SHADER_STAGE_COMPUTE_BIT")))
129 | (enum ((value "0x0000001F") (name "VK_SHADER_STAGE_ALL_GRAPHICS")))
130 | (enum ((value "0x7FFFFFFF") (name "VK_SHADER_STAGE_ALL"))))
131 | (enums ((name "VkBlendOp") (type "enum"))
132 | (enum ((value "0") (name "VK_BLEND_OP_ADD")))
133 | (enum ((alias "VK_BLEND_OP_SUBTRACT") (name "VK_SHIMMED")))
134 | (enum ((value "1") (name "VK_BLEND_OP_SUBTRACT")))
135 | (enum ((value "2") (name "VK_BLEND_OP_REVERSE_SUBTRACT")))
136 | (enum ((value "3") (name "VK_BLEND_OP_MIN")))
137 | (enum ((value "4") (name "VK_BLEND_OP_MAX"))))))
138 |
139 | (let ([config #hash((enable-symbolic-enums . #t))])
140 | (check-equal?
141 | (generate-enum-signature '(type ((category "enum") (name "VkBlendOp")))
142 | enum-registry
143 | #hash()
144 | config)
145 | '(begin
146 | (define _VkBlendOp
147 | (_enum '(VK_BLEND_OP_ADD = 0
148 | VK_SHIMMED = 1
149 | VK_BLEND_OP_SUBTRACT = 1
150 | VK_BLEND_OP_REVERSE_SUBTRACT = 2
151 | VK_BLEND_OP_MIN = 3
152 | VK_BLEND_OP_MAX = 4)
153 | _ufixint))
154 | (define VK_BLEND_OP_ADD 0)
155 | (define VK_SHIMMED 1)
156 | (define VK_BLEND_OP_SUBTRACT 1)
157 | (define VK_BLEND_OP_REVERSE_SUBTRACT 2)
158 | (define VK_BLEND_OP_MIN 3)
159 | (define VK_BLEND_OP_MAX 4)))
160 |
161 | (check-equal?
162 | (generate-enum-signature '(type ((category "enum") (name "NotPresent")))
163 | enum-registry
164 | #hash()
165 | config)
166 | '(begin (define _NotPresent (_enum '() _ufixint))))
167 |
168 | (check-equal?
169 | (generate-enum-signature '(type ((category "enum") (name "VkShaderStageFlagBits")))
170 | enum-registry
171 | #hash()
172 | config)
173 | '(begin
174 | (define _VkShaderStageFlagBits
175 | (_bitmask '(VK_SHADER_STAGE_VERTEX_BIT = 1
176 | VK_SHADER_STAGE_TESSELLATION_CONTROL_BIT = 2
177 | VK_SHADER_STAGE_TESSELLATION_EVALUATION_BIT = 4
178 | VK_SHADER_STAGE_GEOMETRY_BIT = 8
179 | VK_SHADER_STAGE_FRAGMENT_BIT = 16
180 | VK_SHADER_STAGE_COMPUTE_BIT = 32
181 | VK_SHADER_STAGE_ALL_GRAPHICS = 31
182 | VK_SHADER_STAGE_ALL = 2147483647)
183 | _uint))
184 | (define VK_SHADER_STAGE_VERTEX_BIT 1)
185 | (define VK_SHADER_STAGE_TESSELLATION_CONTROL_BIT 2)
186 | (define VK_SHADER_STAGE_TESSELLATION_EVALUATION_BIT 4)
187 | (define VK_SHADER_STAGE_GEOMETRY_BIT 8)
188 | (define VK_SHADER_STAGE_FRAGMENT_BIT 16)
189 | (define VK_SHADER_STAGE_COMPUTE_BIT 32)
190 | (define VK_SHADER_STAGE_ALL_GRAPHICS 31)
191 | (define VK_SHADER_STAGE_ALL 2147483647))))
192 |
193 | (let ([config #hash()])
194 | (check-equal?
195 | (generate-enum-signature '(type ((category "enum") (name "VkBlendOp")))
196 | enum-registry
197 | #hash()
198 | config)
199 | '(begin
200 | (define _VkBlendOp _ufixint)
201 | (define VK_BLEND_OP_ADD 0)
202 | (define VK_SHIMMED 1)
203 | (define VK_BLEND_OP_SUBTRACT 1)
204 | (define VK_BLEND_OP_REVERSE_SUBTRACT 2)
205 | (define VK_BLEND_OP_MIN 3)
206 | (define VK_BLEND_OP_MAX 4)))
207 |
208 | (check-equal?
209 | (generate-enum-signature '(type ((category "enum") (name "NotPresent")))
210 | enum-registry
211 | #hash()
212 | config)
213 | '(begin (define _NotPresent _ufixint)))
214 |
215 | (check-equal?
216 | (generate-enum-signature '(type ((category "enum") (name "VkShaderStageFlagBits")))
217 | enum-registry
218 | #hash()
219 | config)
220 | '(begin
221 | (define _VkShaderStageFlagBits _uint)
222 | (define VK_SHADER_STAGE_VERTEX_BIT 1)
223 | (define VK_SHADER_STAGE_TESSELLATION_CONTROL_BIT 2)
224 | (define VK_SHADER_STAGE_TESSELLATION_EVALUATION_BIT 4)
225 | (define VK_SHADER_STAGE_GEOMETRY_BIT 8)
226 | (define VK_SHADER_STAGE_FRAGMENT_BIT 16)
227 | (define VK_SHADER_STAGE_COMPUTE_BIT 32)
228 | (define VK_SHADER_STAGE_ALL_GRAPHICS 31)
229 | (define VK_SHADER_STAGE_ALL 2147483647)))))
230 |
231 |
232 | (test-equal? "(generate-bitmask-signature)"
233 | (generate-bitmask-signature '(type ((category "bitmask"))
234 | "typedef "
235 | (type "VkFlags")
236 | " "
237 | (name "VkFramebufferCreateFlags")))
238 | '(define _VkFramebufferCreateFlags _VkFlags))
239 |
240 | (test-equal? "(generate-funcpointer-signature)"
241 | (generate-funcpointer-signature
242 | '(type ((category "funcpointer"))
243 | "typedef void* (VKAPI_PTR *" (name "PFN_vkAllocationFunction") ")(\n "
244 | (type "void") "* pUserData,"
245 | (type "size_t") "size,"
246 | (type "size_t") "alignment,"
247 | (type "VkSystemAllocationScope") "allocationScope);"))
248 | '(define _PFN_vkAllocationFunction (_fun _pointer
249 | _size_t
250 | _size_t
251 | _VkSystemAllocationScope
252 | ->
253 | _pointer)))
254 |
255 | (test-case "(generate-maybe-wrapper)"
256 | (test-equal? "vkResult = #f"
257 | (generate-maybe-wrapper #f 'w)
258 | null)
259 | (test-equal? "vkResult = #t, many others"
260 | (generate-maybe-wrapper #t 'w)
261 | '(-> (check-vkResult r 'w))))
262 |
263 | (test-case "(generate-type-spec)"
264 | (test-equal? "Simple type"
265 | (generate-type-spec
266 | '(param (type "VkFlags")
267 | (name "flags")))
268 | '_VkFlags)
269 | (test-equal? "Pointer type"
270 | (generate-type-spec
271 | '(param "const "
272 | (type "VkInstanceCreateInfo")
273 | "* "
274 | (name "pCreateInfo")))
275 | '_pointer))
276 |
277 | (test-case "(generate-command-signature)"
278 | (define command-xexpr
279 | '(command
280 | (proto (type "VkResult") " " (name "vkCreateInstance"))
281 | (param "const "
282 | (type "VkInstanceCreateInfo")
283 | "* "
284 | (name "pCreateInfo"))
285 | (param ((optional "true"))
286 | "const "
287 | (type "VkAllocationCallbacks")
288 | "* "
289 | (name "pAllocator"))
290 | (param (type "VkInstance")
291 | "* "
292 | (name "pInstance"))))
293 | (let ([config #hash((enable-auto-check-vkresult . #t))])
294 | (test-equal? "With auto-check"
295 | (generate-command-signature command-xexpr #f #hash() config)
296 | '(define-vulkan vkCreateInstance
297 | (_fun _pointer
298 | _pointer
299 | _pointer
300 | -> (r : _VkResult)
301 | -> (check-vkResult r 'vkCreateInstance)))))
302 | (let ([config #hash()])
303 | (test-equal? "Without auto-check"
304 | (generate-command-signature command-xexpr config)
305 | '(define-vulkan vkCreateInstance
306 | (_fun _pointer
307 | _pointer
308 | _pointer
309 | -> (r : _VkResult)))))))
310 |
--------------------------------------------------------------------------------
/private/generate/make-unsafe.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ;; Generates a Racket module exposing the raw C API for each Vulkan
4 | ;; version across all extensions and all platforms.
5 |
6 | (provide (all-defined-out))
7 | (require (for-syntax racket/base)
8 | racket/generator
9 | "./shared.rkt")
10 |
11 | (define-syntax-rule (require-fg path id)
12 | (require (rename-in path [in-fragment id])))
13 |
14 | (require-fg "./vkresult-checker.rkt" in-check-vkResult-signature)
15 | (require-fg "./ctypes.rkt" in-ctype-declarations)
16 | (require-fg "./preamble.rkt" in-preamble)
17 | (require-fg "./api-constants.rkt" in-api-constant-declarations)
18 | (require-fg "./typedefs.rkt" in-typedef-declarations)
19 | (require-fg "./handles.rkt" in-handle-declarations)
20 | (require-fg "./defines.rkt" in-relevant-preprocessor-declarations)
21 | (require-fg "./interdependent.rkt" in-interdependent-declarations)
22 |
23 | (define (in-fragment registry [config #hash()])
24 | (in-generator
25 | (yield* (in-preamble registry config))
26 | (yield* (in-check-vkResult-signature registry config))
27 | (yield* (in-ctype-declarations registry config))
28 | (yield* (in-api-constant-declarations registry config))
29 | (yield* (in-typedef-declarations registry config))
30 | (yield* (in-relevant-preprocessor-declarations registry config))
31 | (yield* (in-handle-declarations registry config))
32 | (yield* (in-interdependent-declarations registry config))))
33 |
--------------------------------------------------------------------------------
/private/generate/preamble.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require racket/generator
5 | "../paths.rkt")
6 |
7 | ;; We embed unsafe-preamble.rkt directly so that clients
8 | ;; can generate low-level bindings that can operate
9 | ;; outside of the vulkan collection.
10 | (define (in-fragment registry [config #hash()])
11 | (in-generator
12 | (call-with-input-file
13 | (build-path private-path "unsafe-preamble.rkt")
14 | (λ (in)
15 | (yield (read-line in)) ; Forward #lang line
16 | (let loop ([datum (read in)])
17 | (if (eof-object? datum)
18 | (void)
19 | (begin
20 | (yield datum)
21 | (loop (read in)))))))))
22 |
--------------------------------------------------------------------------------
/private/generate/shared.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out)
4 | (all-from-out racket/generator
5 | racket/string
6 | "../memos.rkt"
7 | "../c.rkt"
8 | "../txexpr.rkt"))
9 |
10 | (require racket/generator
11 | racket/string
12 | "../memos.rkt"
13 | "../c.rkt"
14 | "../txexpr.rkt")
15 |
16 | (define (yield* sequence)
17 | (for ([datum sequence])
18 | (yield datum)))
19 |
20 | (define get-type-elements
21 | (memoizer (λ (registry)
22 | (get-tagged-children (find-first-by-tag 'types registry)))))
23 |
24 | (define get-type-lookup
25 | (memoizer
26 | (λ (types)
27 | (make-immutable-hash (map (λ (x) (cons (get-type-name x) x))
28 | types)))))
29 |
30 | ;; Type names appear in attribute or in CDATA of element.
31 | ;; https://www.khronos.org/registry/vulkan/specs/1.1/registry.html#_attributes_of_type_tags
32 | (define (get-type-name type-element)
33 | (attr-ref type-element
34 | 'name
35 | (λ _
36 | (define name-element
37 | (findf-txexpr type-element
38 | (λ (x) (and (list? x)
39 | (equal? (get-tag x) 'name)))))
40 | (and name-element
41 | (shrink-wrap-cdata name-element)))))
42 |
43 | (define (type-name=? type-element name)
44 | (equal? (get-type-name type-element) name))
45 |
46 | (define (get-type-by-category cat registry)
47 | (findf*-txexpr registry
48 | (λ (x) (and (txexpr? x)
49 | (equal? 'type (get-tag x))
50 | (equal? cat (attr-ref x 'category #f))))))
51 |
--------------------------------------------------------------------------------
/private/generate/typedefs.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ; --------------------------------------------------------------------
4 | ; This module generates Racket code from the
5 | ; elements in the Vulkan specification.
6 |
7 | (provide (all-defined-out))
8 | (require "./shared.rkt")
9 |
10 | (define (in-fragment registry [config #hash()])
11 | (in-generator
12 | (for ([element (get-type-by-category "basetype" registry)])
13 | (yield (generate-basetype-signature element)))))
14 |
15 | (define (generate-basetype-signature type-xexpr)
16 | (define name (get-type-name type-xexpr))
17 | (define maybe-type-element (findf (λ (x) (tag=? 'type x)) (get-elements type-xexpr)))
18 | (define original-type (if maybe-type-element (shrink-wrap-cdata maybe-type-element) name))
19 | `(define ,(cname name)
20 | ,(if (equal? name original-type)
21 | `',(string->symbol name)
22 | (cname original-type))))
23 |
--------------------------------------------------------------------------------
/private/generate/typedefs.test.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (module+ test
4 | (require rackunit
5 | "./typedefs.rkt")
6 |
7 | (test-equal? "(generate-basetype-signature)"
8 | (generate-basetype-signature '(type ((category "basetype"))
9 | "typedef "
10 | (type "uint64_t")
11 | " "
12 | (name "VkDeviceAddress")
13 | ";"))
14 | '(define _VkDeviceAddress _uint64_t)))
15 |
--------------------------------------------------------------------------------
/private/generate/vkresult-checker.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require racket/set
5 | "./shared.rkt")
6 |
7 | (define (in-fragment registry [config #hash()])
8 | (define with-success-codes
9 | (findf*-txexpr registry
10 | (λ (x) (attrs-have-key? x 'successcodes))))
11 |
12 | (define possible-codes
13 | (for/fold ([working (set)])
14 | ([has-codes with-success-codes])
15 | (define comma-separated (attr-ref has-codes 'successcodes))
16 | (define success-code-strings (regexp-split #px"\\s*,\\s*"
17 | (string-trim comma-separated)))
18 | (set-union working (apply set (map string->symbol success-code-strings)))))
19 |
20 | (list
21 | `(define -success-codes ',(set->list possible-codes))
22 | `(define (check-vkResult v who)
23 | (unless (if (symbol? v) (member v -success-codes) (>= v 0))
24 | (error who "failed: ~a" v)))))
25 |
--------------------------------------------------------------------------------
/private/memos.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ;; Responsible for caching the many expensive operations used to
4 | ;; gather information from the Vulkan spec.
5 |
6 | (require racket/contract
7 | racket/dict)
8 |
9 | (provide (all-defined-out))
10 |
11 | (module+ test
12 | (require rackunit))
13 |
14 | (define/contract current-memo-cache
15 | (parameter/c dict?)
16 | (make-parameter (make-hash)))
17 |
18 | (define (memoizer proc [key (gensym)])
19 | (λ A
20 | (define cache (current-memo-cache))
21 | (unless (hash-has-key? cache key)
22 | (hash-set! cache key (apply proc A)))
23 | (hash-ref cache key)))
24 |
25 | (module+ test
26 | (test-case "Save return value from call"
27 | (define a-calls 0)
28 | (define a (memoizer (λ _
29 | (set! a-calls (add1 a-calls))
30 | a-calls)))
31 | (check-eq? (a) (a))
32 | (check-eqv? a-calls 1)
33 | (check-eq? (a 1) (a 1))
34 | (check-eqv? a-calls 1)
35 | (test-case "New cache, new calls"
36 | (parameterize ([current-memo-cache (make-hash)])
37 | (check-eq? (a 1) (a 1))
38 | (check-eqv? a-calls 2)))))
39 |
--------------------------------------------------------------------------------
/private/paths.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require racket/runtime-path)
5 |
6 | (define-runtime-path private-path ".")
7 | (define-runtime-path package-path "..")
8 | (define-runtime-path assets-path "./assets")
9 |
10 |
--------------------------------------------------------------------------------
/private/txexpr.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | ;; Tagged X-expression procedures adapted to this project.
4 |
5 | (provide (all-defined-out)
6 | (all-from-out txexpr))
7 |
8 | (require (only-in racket/string string-trim string-join)
9 | txexpr)
10 |
11 | (define (with-attr name L)
12 | (filter (λ (x) (attrs-have-key? x name)) L))
13 |
14 | (define (tag=? t tx)
15 | (and (txexpr? tx)
16 | (equal? (get-tag tx) t)))
17 |
18 | (define (category=? c tx)
19 | (and (txexpr? tx)
20 | (equal? (attr-ref tx 'category #f) c)))
21 |
22 | (define (find-all-by-tag t tx)
23 | (or (findf*-txexpr tx (λ (x) (tag=? t x)))
24 | '()))
25 |
26 | (define (find-first-by-tag t tx)
27 | (findf-txexpr tx (λ (x) (tag=? t x))))
28 |
29 | (define (get-tagged-children tx)
30 | (filter txexpr? (get-elements tx)))
31 |
32 | (define (get-types-by-category cat types)
33 | (filter (λ (x) (equal? (attr-ref x 'category "") cat))
34 | types))
35 |
36 | (define (shrink-wrap-cdata x)
37 | (string-trim (string-join (filter string? (get-elements x)) "")))
38 |
39 | (define (get-text-in-tagged-child t tx)
40 | (shrink-wrap-cdata (find-first-by-tag t tx)))
41 |
42 | (define (get-all-cdata x)
43 | (foldl (λ (kid str)
44 | (string-append str
45 | (if (string? kid)
46 | kid
47 | (get-all-cdata kid))))
48 | ""
49 | (get-elements x)))
50 |
51 | (define (snatch-cdata t tx #:children-only? [kidsonly #f])
52 | (shrink-wrap-cdata (find-first-by-tag t (if kidsonly (cons (gensym) (cdr tx))
53 | tx))))
54 |
55 | (define (get-elements-of-tag t tx)
56 | (filter (λ (x) (tag=? t x))
57 | (get-elements tx)))
58 |
--------------------------------------------------------------------------------
/private/unsafe-preamble.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require ffi/unsafe ffi/unsafe/define
5 | (only-in setup/dirs get-lib-search-dirs))
6 |
7 | (define-ffi-definer define-vulkan
8 | (let ([os (system-type 'os)])
9 | (define libname (case os
10 | [(windows) "vulkan"]
11 | [else "libvulkan"]))
12 |
13 | (define (get-lib-dirs)
14 | (define vulkan-sdk (getenv "VULKAN_SDK"))
15 | (append
16 | (get-lib-search-dirs)
17 | (if (path-string? vulkan-sdk)
18 | (list (build-path (expand-user-path vulkan-sdk) "lib"))
19 | null)
20 | (case os
21 | [(macosx)
22 | ;; MacOS LunarG installer puts libs here:
23 | (list "/usr/local/lib")]
24 | [else null])))
25 |
26 | (ffi-lib libname (list "1" #f)
27 | #:get-lib-dirs get-lib-dirs))
28 | #:default-make-fail make-not-available)
29 |
30 | (define _VisualID _ulong)
31 | (define _Window _ulong)
32 | (define _RROutput _ulong)
33 | (define _Display 'Display)
34 |
35 | ; Wayland
36 | (define _wl_display 'wl_display)
37 | (define _wl_surface 'wl_surface)
38 |
39 | ; Windows
40 | ; http://web.archive.org/web/20190911051224/https://docs.microsoft.com/en-us/windows/win32/winprog/windows-data-types
41 | (define _HANDLE (_cpointer _void))
42 | (define _HINSTANCE _HANDLE)
43 | (define _HWND _HANDLE)
44 | (define _HMONITOR _HANDLE)
45 | (define _DWORD _ulong)
46 | (define _LPCWSTR (_cpointer _wchar))
47 | (define _SECURITY_ATTRIBUTES 'SECURITY_ATTRIBUTES)
48 |
49 | ; XCB
50 | ; https://code.woboq.org/qt5/include/xcb/xproto.h.html
51 | (define _xcb_visualid_t _uint32)
52 | (define _xcb_window_t _uint32)
53 | (define _xcb_connection_t 'xcb_connection_t)
54 |
55 | ; Zircon (Fuchsia OS)
56 | ; https://fuchsia.googlesource.com/fuchsia/+/master/zircon/system/public/zircon/types.h
57 | (define _zx_handle_t _uint32)
58 |
59 | ; These are apparently behind an NDA. Even if I knew what these were,
60 | ; I couldn't put them here.
61 | ; https://github.com/KhronosGroup/Vulkan-Docs/issues/1000
62 | (define _GgpStreamDescriptor (_cpointer _void))
63 | (define _GgpFrameToken (_cpointer _void))
64 |
65 | (define (VK_MAKE_VERSION major minor patch)
66 | (bitwise-ior (arithmetic-shift major 22)
67 | (arithmetic-shift minor 12)
68 | (arithmetic-shift patch 0)))
69 |
70 | (define VK_API_VERSION_1_0 (VK_MAKE_VERSION 1 0 0))
71 | (define VK_API_VERSION_1_1 (VK_MAKE_VERSION 1 1 0))
72 |
73 | (define (VK_VERSION_MAJOR v)
74 | (arithmetic-shift v -22))
75 | (define (VK_VERSION_MINOR v)
76 | (bitwise-and (arithmetic-shift v -12) #x3ff))
77 | (define (VK_VERSION_PATCH v)
78 | (bitwise-and v #xfff))
79 |
80 | (define (format-vulkan-spec-version spec-v)
81 | (format "~a.~a.~a"
82 | (VK_VERSION_MAJOR spec-v)
83 | (VK_VERSION_MINOR spec-v)
84 | (VK_VERSION_PATCH spec-v)))
85 |
--------------------------------------------------------------------------------
/private/writer.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 | (provide (all-defined-out))
4 | (require racket/stream
5 | racket/string
6 | "./paths.rkt")
7 |
8 | ;; This is how we deliver Racket code generated using the Vulkan spec.
9 | (define (write-sequence sequence [out (current-output-port)])
10 | (define stm (sequence->stream sequence))
11 | (define first-element (stream-first stm))
12 |
13 | (if (and (string? first-element) (string-prefix? first-element "#lang"))
14 | (displayln first-element out)
15 | (writeln first-element out))
16 |
17 | (for ([declaration (stream-rest stm)])
18 | (writeln declaration out)))
19 |
20 | (module+ test
21 | (require racket/generator
22 | racket/port
23 | rackunit)
24 |
25 | (test-case "Write code fragment"
26 | (define-values (i o) (make-pipe))
27 | (define registry '(dummy))
28 | (write-sequence (in-generator (yield '(a)) (yield '(b)) (yield '(c))) o)
29 | (close-output-port o)
30 | (test-equal? "Read values match order from generator"
31 | (port->list read i)
32 | '((a) (b) (c))))
33 |
34 | (test-case "Write code module"
35 | (define-values (i o) (make-pipe))
36 | (write-sequence (in-generator (yield "#lang something") (yield '(b)))
37 | o)
38 | (close-output-port o)
39 | (test-equal? "#lang line preserved"
40 | (read-line i)
41 | "#lang something")
42 | (test-equal? "Datum follows string"
43 | (read i) '(b))))
44 |
--------------------------------------------------------------------------------
/scribblings/maintainers.scrbl:
--------------------------------------------------------------------------------
1 | #lang scribble/manual
2 |
3 | @title{Contributing}
4 |
5 | The official repository @hyperlink["https://github.com/zyrolasting/racket-vulkan"]{is on GitHub}.
6 | The source code tracks the @hyperlink["https://www.khronos.org/registry/vulkan/"]{Vulkan Registry}.
7 |
8 | @section{What's Needed Right Now}
9 | This collection depends on contributions of code or funding to keep up
10 | with the rapid development of Vulkan. The GitHub README shows funding
11 | oppurtunities, while this document focuses on technical contributions.
12 |
13 | @bold{Right now the project has a strong need for example Vulkan
14 | applications.} You can make an impact by porting C programs to Racket.
15 | Each such application acts as a functional test for continuous
16 | integration purposes, which covers far more than unit tests
17 | ever could.
18 |
19 | @section{Maintenance Guide}
20 | This section is only meant to aid high-level understanding
21 | of the project and its technical needs. It is not a reference
22 | for implementation details.
23 |
24 | @subsection{System Design}
25 | This project's job is to generate Racket code that uses Vulkan
26 | according to an end user's assumptions.
27 |
28 | The system must remain flexible in the face of any change to a
29 | machine-readable Vulkan specification. It does this by giving an
30 | @italic{end user} the means to keep their Racket code up to date with
31 | Vulkan, even if the source code of this project is @italic{out of
32 | date}.
33 |
34 | This is possible because the specification and code generators can
35 | change independently, and are accessible through a public API.
36 |
37 | @tt{vk.xml} in particular acts as input to all code generators in the
38 | project. Each generator lazily produces a sequence of code from a
39 | specification according to its own assumptions. You have to know how
40 | to apply generators together to do something meaningful. I did it this
41 | way because even backwards-compatible changes to a Vulkan
42 | specification can break a model of it, so having a collection of
43 | specialized generators makes it easier to manage assumptions.
44 |
45 | @subsection{Maintenance Tasks}
46 | This project maintains its own mirror of @tt{vk.xml} so it can
47 | function offline, and the built-in code generators track its
48 | contents. To update the project, maintainers should periodically write
49 | a new version of the XML mirror, regenerate a Vulkan integration, and
50 | run all relevant tests.
51 |
52 | Here is a session I normally use to update the project, assuming the
53 | package is installed on the system using @litchar{raco pkg install
54 | --link}. I use fake paths to relevant files in the below snippet in
55 | case the actual files move around the project.
56 |
57 | @verbatim[#:indent 4]|{
58 | # Download the latest vk.xml and replace the local mirror
59 | ravk --latest show spec > /path/to/vk.xml
60 |
61 | # Regenerate the unsafe FFI bindings.
62 | # If this errors out, a code generator hit a runtime error
63 | # and is likely incompatible with the XML update.
64 | ravk generate unsafe > /path/to/unsafe.rkt
65 |
66 | # Recompile the project.
67 | # If this errors out, the unsafe bindings contain
68 | # incorrect Racket code. This points to a logic
69 | # error in a code generator.
70 | raco setup vulkan
71 |
72 | # Run unit tests
73 | raco test --jobs 8 --drdr -p vulkan
74 |
75 | # If Vulkan is actually installed on the system,
76 | # use Racket or GRacket to use example
77 | # applications as functional tests.
78 | racket /path/to/examples/app1.rkt
79 | racket /path/to/examples/app2.rkt
80 | ...
81 | }|
82 |
83 | Going through this script creates confidence in the package
84 | and a Vulkan specification upgrade.
85 |
86 | Should a new @tt{vk.xml} undergo a backwards-incompatible change, the
87 | code generators should be archived such that they apply to prior
88 | versions. A new set of code generators should henceforth process
89 | the local mirror. There is not yet a way to pick only relevant
90 | code generators given a spec version, but the implementation
91 | will come when it's needed.
92 |
--------------------------------------------------------------------------------
/scribblings/ravk.scrbl:
--------------------------------------------------------------------------------
1 | #lang scribble/manual
2 |
3 | @require[@for-label[racket/base
4 | racket/dict
5 | racket/generator
6 | racket/string
7 | ffi/unsafe
8 | @only-in[txexpr findf*-txexpr
9 | attr-ref]
10 | vulkan/spec]]
11 |
12 | @title{@tt{ravk}: Vulkan Ecosystem Controls}
13 |
14 | @tt{ravk} (pronounced "Ravick") is a command-line interface
15 | that reports useful facts about a Vulkan integration in terms
16 | of a @litchar{vk.xml} specification.
17 |
18 | You can use @tt{ravk} to generate modules that operate
19 | independently from this collection, generate Racket
20 | code fragments for auditing purposes, and to review
21 | information about the Vulkan specification itself.
22 |
23 | Many commands operate on a copy of @tt{vk.xml}, and you
24 | can specify which to use.
25 |
26 | @verbatim[#:indent 4]|{
27 | $ ravk ... # Use local mirror of vk.xml
28 | $ ravk --latest ... # (or -l) Use latest vk.xml from the Khronos Group.
29 | }|
30 |
31 | @section{@tt{ravk show}: Review key information}
32 |
33 | Use @tt{ravk show} to view helpful data about the code that
34 | will run on the host system in an integration.
35 |
36 | @subsection{@tt{ravk show spec}: Specification review}
37 |
38 | It's critically important that all concerned parties
39 | keep an eye on the Vulkan specification. You will need
40 | information about the spec to know if you should upgrade
41 | this collection or use a different version of @tt{vk.xml} to
42 | generate code.
43 |
44 | @verbatim[#:indent 4]|{
45 | $ ravk show spec # prints local mirror of vk.xml for offline use.
46 | $ ravk show spec --xexpr # (or -x) prints vk.xml as an X-expression. Ignored if -v is set.
47 | $ ravk show spec --version # (or -v) Show specification version.
48 | $ ravk -l show spec -x # X-expression of latest vk.xml}|
49 |
50 | @section{@tt{ravk generate}: Generate Code to use Vulkan}
51 |
52 | @verbatim[#:indent 4]|{
53 | $ ravk generate heading.rkt body.rkt footer.rkt ...
54 | }|
55 |
56 | The @tt{generate} command prints code to STDOUT. The output
57 | may be a full Racket module body complete with a @litchar{#lang} line,
58 | or a parseable fragment that follows certain assumptions.
59 |
60 | Use this command to inspect the Vulkan registry with
61 | custom views, or to prepare code with an adjustable
62 | level of overhead.
63 |
64 | The arguments are paths to Racket modules that must provide a
65 | procedure called @racket[in-fragment]. It returns a sequence of Racket
66 | code given a Vulkan specification and a shared configuration.
67 |
68 | @racketblock[
69 | (require racket/generator)
70 |
71 | (define (in-fragment registry [config #hash()])
72 | (in-generator
73 | (yield "#lang racket/base")
74 | (yield '(define something 1))))]
75 |
76 | If the first element of the sequence is a string, it will be printed in @racket[display]
77 | mode. This is to support @litchar{#lang} lines. In this case, a trailing newline character
78 | is optional. In all other cases, each element of the sequence is a datum that, when printed
79 | in @racket[write] mode, will appear in a file as a valid Racket expression.
80 |
81 | @racket[config] is populated by the @tt{ravk generate} command such that the long form
82 | name of each option is a key in the dictionary (e.g. @litchar{--enable-auto-check-vkresult}
83 | has the key @racket['enable-auto-check-vkresult]. Keys might not be present, and the value
84 | of each key depends on the option. See @secref{genconfig}.
85 |
86 | The output of each module appears follows the order declared in the
87 | command line. There is no guarentee that the output will be a valid
88 | program, so you have to know what you are asking for.
89 |
90 | @subsection{Using Built-in Generators}
91 |
92 | Besides paths to Racket modules, you can symbolically refer
93 | to built-in generators. In addition, the output of
94 | @litchar{ravk generate unsafe} in particular is the
95 | content of @racketmodname[vulkan/unsafe].
96 |
97 | This effectively locks down a copy of Racket code against a Vulkan
98 | spec version, and makes it possible for some packages to operate
99 | without a dependency on this collection, and with minimal overhead.
100 |
101 | @verbatim[#:indent 4]|{
102 | $ ravk generate unsafe > unsafe.rkt
103 | }|
104 |
105 | Here are the currently supported built-in generators:
106 |
107 | @tabular[
108 | #:style 'boxed
109 | #:column-properties '(left right)
110 | '(("unsafe" "FFI bindings for Vulkan across all platforms and extensions for the given specification."))]
111 |
112 | @subsection{Example: Your First Code Generator}
113 |
114 | A code generator module lazily produces Racket code in terms
115 | of a Vulkan specification. To write one, you need to
116 | know the @hyperlink["https://www.khronos.org/registry/vulkan/specs/1.1/registry.html"]{Vulkan Registry}.
117 |
118 | It so happens that code generator modules are easy to write with Racket
119 | @secref["Generators" #:doc '(lib
120 | "scribblings/reference/reference.scrbl")]. Be careful not to confuse
121 | the two.
122 |
123 | In this example, we generate a Racket module that prints platform-specific
124 | type names when instantiated. @racket[registry-xexpr] is bound to an
125 | X-expression form of the @tt{} (root) element of a Vulkan
126 | specification.
127 |
128 | @racketmod[#:file "gen-platform-type-printer.rkt"
129 | racket/base
130 |
131 | (provide in-fragment)
132 | (require racket/generator
133 | racket/string
134 | txexpr)
135 |
136 | (define (in-fragment registry-xexpr [config #hash()])
137 | (in-generator
138 | (yield "#lang racket/base")
139 | (define platform-type-elements
140 | (findf*-txexpr registry-xexpr
141 | (λ (x)
142 | (and (list? x)
143 | (string-suffix? (attr-ref x 'requires "")
144 | ".h"))))
145 | (for ([element platform-type-elements])
146 | (yield `(displayln ,(attr-ref element 'name)))))))
147 | ]
148 |
149 | For Vulkan 1.1.126, this session holds:
150 |
151 | @verbatim[#:indent 4]|{
152 | $ ravk generate gen-platform-type-printer.rkt > print-platform-types.rkt
153 | $ racket print-platform-types.rkt
154 | Display
155 | VisualID
156 | Window
157 | RROutput
158 | wl_display
159 | wl_surface
160 | HINSTANCE
161 | HWND
162 | HMONITOR
163 | HANDLE
164 | SECURITY_ATTRIBUTES
165 | DWORD
166 | LPCWSTR
167 | xcb_connection_t
168 | xcb_visualid_t
169 | xcb_window_t
170 | zx_handle_t
171 | GgpStreamDescriptor
172 | GgpFrameToken
173 | }|
174 |
175 | Code generators can also generate documentation or report data.
176 | The possibilities are exciting, but some words of warning:
177 |
178 | @itemlist[
179 | @item{A search through the registry element is expensive. Use memoization and limit your search space whenever possible.}
180 | @item{The Vulkan specification is machine-readable, but human-comprehensible. Expect to write weird and wonderful things to make your program work reliably. Mostly weird.}
181 | @item{There are no guarentees that the order of data you encounter is the order it should appear in Racket.}
182 | ]
183 |
184 | @subsection[#:tag "genconfig"]{Generator Configuration Space}
185 |
186 | The built-in code generators share configuration that controls
187 | their output. You can control this configuration using command-line
188 | flags.
189 |
190 | @subsubsection{Switches}
191 |
192 | The following values are booleans for @racket[in-fragment]'s purposes.
193 | If the flag is not set, the key will not be set in the dictionary
194 | passed to @racket[in-fragment].
195 |
196 | @itemlist[
197 | @item{@litchar{--enable-auto-check-vkresult}: When set, all foreign
198 | function calls that return a @tt{VkResult} will be automatically
199 | checked in a wrapping Racket procedure. If the code is an error code,
200 | the wrapping procedure will raise @racket[exn:fail].}
201 | @item{@litchar{--enable-symbolic-enums}: When set, all C enum types
202 | are represented using either @racket[_enum] or @racket[_bitmask]
203 | depending on their intended use. You must then use symbols to represent
204 | enumerants according to the rules of @racket[_enum] or @racket[_bitmask]
205 | in your program.}
206 | ]
207 |
--------------------------------------------------------------------------------
/scribblings/setup.scrbl:
--------------------------------------------------------------------------------
1 | #lang scribble/manual
2 | @require[@for-label[setup/dirs
3 | racket/base]]
4 |
5 | @title{Setup}
6 |
7 | Preparing this project for your system depends on what you want
8 | to do. If you just want to use Vulkan for your program, follow the
9 | first set of instructions. If you are a contributor
10 | or want to use your copy of the source code, then
11 | follow the second set of instructions.
12 |
13 |
14 | @section{For Most Users}
15 |
16 | @itemlist[#:style 'ordered
17 | @item{Install this package using @litchar{raco pkg install vulkan}}
18 | @item{Install the @hyperlink["https://www.lunarg.com/vulkan-sdk/"]{Vulkan SDK},
19 | or the latest graphic drivers for your system with Vulkan support.}
20 | @item{Confirm that @litchar{libvulkan.so} (Linux, etc.) or @litchar{vulkan-1.dll}
21 | (Windows) are accessible via @racket[get-lib-search-dirs].}
22 | ]
23 |
24 |
25 | @section{For Contributors and Power Users}
26 |
27 | @itemlist[#:style 'ordered
28 | @item{Clone https://github.com/zyrolasting/racket-vulkan/}
29 | @item{Run @litchar{raco pkg remove vulkan} to remove any existing copy of this collection on your system.}
30 | @item{In the new directory, run @litchar{raco pkg install --link} to install the collection as a link to your copy of the source.}
31 | @item{Install the @hyperlink["https://www.lunarg.com/vulkan-sdk/"]{Vulkan SDK} or the latest graphic drivers for your system
32 | with Vulkan support.}
33 | @item{Confirm that @litchar{libvulkan.so} (Linux, etc.) or @litchar{vulkan-1.dll}
34 | (Windows) are accessible via @racket[get-lib-search-dirs].}
35 | @item{Run the unit tests using @litchar{raco test -x -p vulkan} to verify that the code is operational.}
36 | @item{Run @litchar{racket examples/minimal.rkt} in the repository to make sure you can create and destroy a Vulkan instance.}]
37 |
38 | As an aside, if you ever modify @litchar{unsafe.rkt}, be sure to run
39 | @litchar{raco make} or @litchar{raco setup} on it to capture any changes.
40 | It takes a while to compile.
41 |
42 |
--------------------------------------------------------------------------------
/scribblings/spec.scrbl:
--------------------------------------------------------------------------------
1 | #lang scribble/manual
2 | @require[@for-label[vulkan/spec
3 | racket/base
4 | racket/contract]]
5 |
6 | @title{Controlling the Vulkan Specification}
7 |
8 | @defmodule[vulkan/spec]
9 |
10 | The @racketmodname[vulkan/spec] module provides data from
11 | @litchar{vk.xml}, the machine-readable specification of Vulkan. It can
12 | download the latest copy from the Khronos Group, and convert the
13 | contents of any @litchar{vk.xml} to an X-expression.
14 |
15 | @defproc[(vulkan-spec? [v any/c]) boolean?]{
16 | Returns @racket[#t] if argument is a Vulkan specification according to
17 | this collection, @racket[#f] otherwise.
18 |
19 | Currently the validation is not always correct because it does not yet support
20 | RelaxNG. This will come in a future version.
21 | }
22 |
23 | @defthing[vulkan-spec-sources/c (symbols 'local 'remote)]{
24 | These symbols select which @litchar{vk.xml} to use where applicable.
25 |
26 | @itemlist[
27 | @item{@racket['local] references the mirror of @litchar{vk.xml} packaged with this collection. It may be out of date, but can be used offline.}
28 | @item{@racket['remote] references the latest official copy of @litchar{vk.xml} published by the Khronos Group.}
29 | ]
30 | }
31 |
32 | @defproc[(get-vulkan-spec [spec-source vulkan-spec-sources/c 'local])
33 | vulkan-spec?]{
34 | Returns the machine-readable Vulkan specification from the given source.
35 | }
36 |
--------------------------------------------------------------------------------
/scribblings/unsafe.scrbl:
--------------------------------------------------------------------------------
1 | #lang scribble/manual
2 | @require[@for-label[racket/base
3 | racket/contract
4 | @except-in[ffi/unsafe ->]
5 | ffi/unsafe/define
6 | vulkan/unsafe]
7 | ffi/unsafe]
8 |
9 | @title{Unsafe Bindings}
10 | @defmodule[vulkan/unsafe]
11 |
12 | The unsafe module is exactly as the name implies.
13 | @bold{Use at your own risk.}
14 |
15 | @racketmodname[vulkan/unsafe] is just the output of @litchar{ravk
16 | generate unsafe}. You can generate your own copy to use Vulkan
17 | bindings according to this section without a dependency on this
18 | collection.
19 |
20 | A copy of @racketmodname[vulkan/unsafe] provides over 2200 bindings
21 | representing all supported and deprecated Vulkan structs, unions,
22 | enumerated types, constants and functions across all platforms,
23 | extensions, and published Vulkan API verions. There are few
24 | protections against misuse. @italic{Any mistakes risk undefined
25 | behavior, race conditions, and memory leaks}. Do not expect clear
26 | error messages, strong validation, or concise code.
27 |
28 | Here you will also find platform-specific code,
29 | necessary loading calls to communicate with Vulkan,
30 | and a curated list of utilities not generated from a specification.
31 |
32 | On instantiation, this module will attempt to load the host
33 | platform's Vulkan library. Should this fail, the module will
34 | raise an error.
35 |
36 |
37 | @section{Design Considerations}
38 |
39 | Since @racketmodname[vulkan/unsafe] exposes a raw API, you can easily
40 | port a C program using Vulkan to Racket. You can also use this module
41 | to write your own abstractions in terms of @racketmodname[ffi/unsafe],
42 | or to study established Vulkan literature while using Racket.
43 |
44 | It is possible to write cross-platform and backwards-compatible Vulkan
45 | applications with this module, but you are responsible for detecting
46 | the platform and using APIs from the correct version.
47 |
48 |
49 | @section{What Did I Just Load?}
50 |
51 | When you @racket[require] this module, you may assume that all Vulkan
52 | identifiers defined in the specification for the core API and all
53 | extensions are provided. I cannot document every binding by hand,
54 | but I thankfully don't have to. The translation from C to Racket is
55 | not 1-to-1, but it is close enough where you can compare the below
56 | list of translation rules against a Vulkan specification document
57 | to know what bindings are available:
58 |
59 | @itemlist[
60 | @item{All identifiers acting as C types are prefixed with an underscore. So, the C type @tt{VkInstance} is bound to the @tt{_VkInstance} identifier in Racket.}
61 | @item{API constants and enumerants have identifiers bound to a Racket value. e.g. @tt{VK_API_VERSION_1_1}.}
62 | @item{All Vulkan functions are provided as Racket procedures with an identifier matching the name. e.g. The @tt{vkCreateInstance} C function is a Racket procedure also named @tt{vkCreateInstance}.}
63 | @item{A Racket procedure's presence is not a guarentee that the associated C function is available as an object in the system library. If you call @tt{vkCreateAndroidSurfaceKHR} on a non-Android platform, the C function will not be found.}
64 | @item{Unions are generated with accessor procedures that wrap @racket[union-ref]. So if a union @tt{U} has a member named @tt{floats}, you can access all Racket values converted from that union using @tt{(U-floats union-val)}.}
65 | @item{Structs are created using @racket[define-cstruct], meaning that all bindings generated from that form exist for every Vulkan structure (e.g. @tt{_VkImageCreateInfo-pointer/null}).}
66 | ]
67 |
68 | @section{Platform-Specific Definitions}
69 |
70 | Vulkan is itself platform-agnostic, but extensions are necessary to
71 | integrate with platforms. Some identifiers are bound to interned
72 | symbols--such as @racket[_Display]-- because they are meant for use in
73 | @racket[_cpointer] or @racket[_cpointer/null].
74 |
75 | @subsection{X + RandR}
76 | @deftogether[(
77 | @defthing[_VisualID ctype? #:value _ulong]
78 | @defthing[_Window ctype? #:value _ulong]
79 | @defthing[_RROutput ctype? #:value _ulong]
80 | @defthing[_Display symbol? #:value 'Display]
81 | )]{}
82 |
83 | @subsection{Wayland}
84 | @deftogether[(
85 | @defthing[_wl_display symbol? #:value 'wl_display]
86 | @defthing[_wl_surface symbol? #:value 'wl_surface]
87 | )]{}
88 |
89 | @subsection{Windows}
90 | @deftogether[(
91 | @defthing[_HANDLE ctype? #:value (_cpointer _void)]
92 | @defthing[_HINSTANCE ctype? #:value _HANDLE]
93 | @defthing[_HWND ctype? #:value _HANDLE]
94 | @defthing[_HMONITOR ctype? #:value _HANDLE]
95 | @defthing[_DWORD ctype? #:value _ulong]
96 | @defthing[_LPCWSTR ctype? #:value (_cpointer _wchar)]
97 | @defthing[_SECURITY_ATTRIBUTES symbol? #:value 'SECURITY_ATTRIBUTES]
98 | )]{}
99 |
100 | @subsection{XCB}
101 | @deftogether[(
102 | @defthing[_xcb_visualid_t ctype? #:value _uint32]
103 | @defthing[_xcb_window_t ctype? #:value _uint32]
104 | @defthing[_xcb_connection_t symbol? #:value 'xcb_connection_t]
105 | )]{}
106 |
107 | @subsection{Zircon (Fuchsia OS)}
108 | @defthing[_zx_handle_t ctype? #:value _uint32]{}
109 |
110 | @subsection{Google Games}
111 | @deftogether[(
112 | @defthing[_GgpStreamDescriptor ctype? #:value (_cpointer _void)]
113 | @defthing[_GgpFrameToken ctype? #:value (_cpointer _void)]
114 | )]{
115 | Be warned that these values are likely incorrect, and are apparently
116 | @hyperlink["https://github.com/KhronosGroup/Vulkan-Docs/issues/1000"]{behind
117 | an NDA}. Even if I knew what these were, I couldn't publish them here. If
118 | you are the rare person who happened to sign this NDA and wish to use
119 | Racket on Google Games, you may need to use a different binding. I
120 | leave them here as @tt{void*} in the hopes you can use them and to clarify
121 | that they are relevant to you.
122 | }
123 |
124 |
125 | @section{Spec Version Procedures}
126 |
127 | Some core Vulkan signatures are implemented as C preprocessor macros
128 | that are difficult to transform directly to Racket. Chief among them
129 | are the expressions of specification versions that are relevant for
130 | runtime and operational use. Their names are preserved as they appear
131 | in C for consistency.
132 |
133 | @defproc[(VK_MAKE_VERSION [major exact-nonnegative-integer?]
134 | [minor exact-nonnegative-integer?]
135 | [patch exact-nonnegative-integer?])
136 | exact-positive-integer?]{
137 | This is a Racket variant of the @litchar{VK_MAKE_VERSION} macro from
138 | @litchar{vulkan.h}.
139 | }
140 |
141 | @deftogether[(
142 | @defthing[VK_API_VERSION_1_0 exact-positive-integer? #:value (VK_MAKE_VERSION 1 0 0)]
143 | @defthing[VK_API_VERSION_1_1 exact-positive-integer? #:value (VK_MAKE_VERSION 1 1 0)]
144 | )]{
145 | Racket-specific Vulkan version values.
146 | }
147 |
148 | @deftogether[(
149 | @defproc[(VK_VERSION_MAJOR [v exact-positive-integer?]) exact-positive-integer?]
150 | @defproc[(VK_VERSION_MINOR [v exact-positive-integer?]) exact-positive-integer?]
151 | @defproc[(VK_VERSION_PATCH [v exact-positive-integer?]) exact-positive-integer?]
152 | )]{
153 | Extracts version numbers from a value constructed by @racket[VK_MAKE_VERSION].
154 | }
155 |
156 |
157 | @section{Additional Procedures}
158 |
159 | @defproc[(check-vkResult [v any/c] [who symbol?]) void?]{
160 | Equivalent to @racket[(error who "failed: ~a" v)] if @racket[v] is not
161 | a @tt{VkResult} success code.
162 | }
163 |
164 | @defproc[(format-vulkan-spec-version [spec-version exact-positive-integer?]) string?]{
165 | Equivalent to:
166 |
167 | @racketblock[
168 | (format "~a.~a.~a"
169 | (VK_VERSION_MAJOR spec-version)
170 | (VK_VERSION_MINOR spec-version)
171 | (VK_VERSION_PATCH spec-version))
172 | ]
173 | }
174 |
--------------------------------------------------------------------------------
/scribblings/vulkan.scrbl:
--------------------------------------------------------------------------------
1 | #lang scribble/manual
2 | @require[@for-label[racket/base]]
3 |
4 | @title{Vulkan API Integration}
5 | @author[(author+email "Sage L. Gerard" "sage@sagegerard.com" #:obfuscate? #t)]
6 |
7 | This collection integrates Racket and the Vulkan API, with a focus on
8 | low overhead and C code equivalency. With this collection, it is
9 | possible to use Racket to follow along with Vulkan tutorials written
10 | for C and C++.
11 |
12 | @local-table-of-contents[]
13 | @include-section{setup.scrbl}
14 | @include-section{spec.scrbl}
15 | @include-section{unsafe.scrbl}
16 | @include-section{ravk.scrbl}
17 | @include-section{maintainers.scrbl}
--------------------------------------------------------------------------------
/spec.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 |
3 |
4 | ;---------------------------------------------------------------------------------------------------
5 | ; This module offers the Vulkan API specification in machine-readable form.
6 |
7 | (require xml
8 | racket/contract
9 | "./private/paths.rkt")
10 |
11 | (provide
12 | vulkan-spec-sources/c
13 | (contract-out
14 | [get-spec-port (-> vulkan-spec-sources/c input-port?)]
15 | [get-vulkan-spec (-> vulkan-spec-sources/c vulkan-spec?)] ; Computes Vulkan API spec
16 | [vulkan-spec? (-> any/c boolean?)])) ; Returns if argument is a Vulkan specification according to this library
17 |
18 | ; Specification sources can be the local file system, or a remote system on the Internet
19 | (define vulkan-spec-sources/c (symbols 'local 'remote))
20 |
21 | ; What 'local implies
22 | (define local-mirror-path (build-path assets-path "vk.xml"))
23 |
24 | ; Run this script directly to see Vulkan spec xexpr on (current-output-port)
25 | (module+ main (writeln (get-vulkan-spec)))
26 |
27 |
28 | ;---------------------------------------------------------------------------------------------------
29 | ; Implementation
30 |
31 | (require racket/file
32 | racket/port
33 | net/url)
34 |
35 | ; TODO: Because xml does not (yet?) support DTD processing and
36 | ; RelaxNG is needed to generate declaration info, I'll ride
37 | ; on optimism for the time being.
38 | (define (vulkan-spec? v)
39 | (and (xexpr? v) (eq? (car v) 'registry)))
40 |
41 | ; Downloads Vulkan API spec from official source.
42 | ; Multiple versions of the API may be generated off master.
43 | (define (source-spec-from-internet)
44 | (get-pure-port (string->url "https://raw.githubusercontent.com/KhronosGroup/Vulkan-Docs/master/xml/vk.xml")))
45 |
46 | ; Returns input port to a mirror of the Vulkan API spec from this package distribution.
47 | (define (source-spec-from-local-mirror)
48 | (open-input-file local-mirror-path))
49 |
50 | ; Writes network-sourced content to the local mirror.
51 | (define (sync-local-mirror! proc)
52 | (define backup (file->string local-mirror-path))
53 | (with-handlers ([(λ _ #t)
54 | (display-to-file #:exists 'replace
55 | backup
56 | local-mirror-path)])
57 | (call-with-output-file*
58 | local-mirror-path
59 | #:exists 'replace
60 | (lambda (port)
61 | (display (port->string (source-spec-from-internet)) port)))))
62 |
63 | ; Returns an input port given a desired source
64 | (define (get-spec-port source)
65 | (if (eq? source 'local)
66 | (source-spec-from-local-mirror)
67 | (source-spec-from-internet)))
68 |
69 | ; Returns the Vulkan API specification
70 | (define (get-vulkan-spec [spec-source 'local])
71 | (define p (get-spec-port spec-source))
72 | (define doc (read-xml p))
73 | (close-input-port p)
74 | (xml->xexpr (document-element doc)))
75 |
76 | (module+ test
77 | (require rackunit)
78 | (check-pred xexpr? (get-vulkan-spec 'local)))
79 |
--------------------------------------------------------------------------------