├── .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://img.shields.io/badge/%E2%99%A5-Support%20Ethical%20Software-red)](https://sagegerard.com/subscribe.html) 2 | [![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) 3 | [![Scribble](https://img.shields.io/badge/Docs-Scribble-blue.svg)](http://docs.racket-lang.org/vulkan/index.html) 4 | [![](https://tokei.rs/b1/github/zyrolasting/racket-vulkan)](https://github.com/zyrolasting/racket-vulkan) 5 | 6 |

7 | Racket + Vulkan® = awesome 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 | --------------------------------------------------------------------------------