├── .gitignore ├── 3bgl-shader-example.asd ├── 3bgl-shader.asd ├── README.md ├── api.lisp ├── cl-functions.lisp ├── compiler.lisp ├── example-shaders.lisp ├── example.lisp ├── finalize-inference.lisp ├── glsl-base.lisp ├── glsl.lisp ├── infer.lisp ├── ir.lisp ├── old-utils.lisp ├── package.lisp ├── printer.lisp ├── spirv-functions.lisp ├── spirv-test-shaders.lisp ├── spirv.lisp ├── todo.org ├── types.lisp ├── utils.lisp └── walker.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl -------------------------------------------------------------------------------- /3bgl-shader-example.asd: -------------------------------------------------------------------------------- 1 | (defsystem :3bgl-shader-example 2 | :depends-on (3bgl-shader mathkit cl-glut cl-glu) 3 | :serial t 4 | :components ((:file "example-shaders") 5 | (:file "example"))) 6 | -------------------------------------------------------------------------------- /3bgl-shader.asd: -------------------------------------------------------------------------------- 1 | (defsystem :3bgl-shader 2 | :description "CL-hosted CL-like DSL for generating GLSL" 3 | :license "MIT" 4 | :author "Bart Botta <00003b at gmail.com>" 5 | :depends-on (alexandria bordeaux-threads cl-opengl) 6 | :serial t 7 | :components ((:file "package") 8 | (:file "ir") 9 | (:file "walker") 10 | (:file "types") 11 | (:file "infer") 12 | (:file "glsl-base") 13 | (:file "cl-functions") 14 | (:file "glsl") 15 | (:file "finalize-inference") 16 | (:file "printer") 17 | (:file "compiler") 18 | (:file "api") 19 | (:file "old-utils") 20 | (:file "utils"))) 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ### 3bgl-shader: a Common Lisp DSL for generating GLSL shaders 2 | 3 | ### Features 4 | 5 | * looks more-or-less like CL 6 | * type inference 7 | * hooks for interactive use 8 | * automatic overloaded functions 9 | 10 | ### Minimal Example shader program 11 | 12 | Just transform the vertex, and send color to be interpolated. 13 | (More examples can be found [here](https://github.com/3b/3bgl-shader/blob/master/example-shaders.lisp).) 14 | 15 | ```Lisp 16 | ;; define a package for the shader functions, :USEing :3BGL-GLSL/CL 17 | (cl:defpackage #:shader 18 | (:use :3bgl-glsl/cl) 19 | (cl:in-package #:shader) 20 | 21 | ;; vertex attributes, need to specify types for all 'external' 22 | ;; interfaces and globals (inputs, outputs, uniforms, varyings) 23 | (input position :vec4 :location 0) 24 | (input color :vec4 :location 1) 25 | 26 | ;; final output 27 | (output out-color :vec4 :stage :fragment) 28 | 29 | ;; model-view-projection matrix 30 | (uniform mvp :mat4) 31 | 32 | ;; interface between vertex and fragment shader 33 | (interface varyings (:out (:vertex outs) 34 | :in (:fragment ins)) 35 | (color :vec4)) 36 | 37 | ;; vertex shader (names are arbitrary) 38 | (defun vertex () 39 | (setf (@ outs color) color 40 | gl-position (* mvp position))) 41 | 42 | ;; fragment shader 43 | (defun boring-fragment () 44 | (setf out-color (@ ins color))) 45 | 46 | ;; not quite CL:defconstant, need to specify a type 47 | (defconstant +scale+ 2.0 :float) 48 | ;; a helper function 49 | (defun invert-and-scale (x) 50 | ;; RETURN is GLSL return rather than CL:RETURN, and is required for 51 | ;; functions that return a value 52 | (return (* +scale+ (- 1 x)))) 53 | 54 | ;; an alternate fragment shader 55 | (defun inverted-fragment () 56 | (setf out-color (invert-and-scale (@ ins color)))) 57 | ``` 58 | 59 | #### Convert to glsl 60 | 61 | ```Lisp 62 | (3bgl-shaders:generate-stage :vertex 'shader::vertex) 63 | (3bgl-shaders:generate-stage :fragment 'shader::boring-fragment) 64 | (3bgl-shaders:generate-stage :fragment 'shader::inverted-fragment) 65 | ``` 66 | 67 | results: 68 | ```glsl 69 | // vertex shader: 70 | #version 450 71 | out varyings { 72 | vec4 color; 73 | } outs; 74 | 75 | layout(location = 1) in vec4 color; 76 | 77 | uniform mat4 mvp; 78 | 79 | layout(location = 0) in vec4 position; 80 | 81 | void main () { 82 | outs.color = color; 83 | gl_Position = (mvp * position); 84 | } 85 | 86 | // boring fragment shader: 87 | #version 450 88 | out vec4 outColor; 89 | 90 | in varyings { 91 | vec4 color; 92 | } ins; 93 | 94 | void main () { 95 | outColor = ins.color; 96 | } 97 | 98 | // inverted fragment shader 99 | #version 450 100 | out vec4 outColor; 101 | 102 | const float SCALE = 2.0; 103 | in varyings { 104 | vec4 color; 105 | } ins; 106 | 107 | vec4 invertAndScale (vec4 x) { 108 | return (SCALE * (1 - x)); 109 | } 110 | 111 | void main () { 112 | outColor = invertAndScale(ins.color); 113 | } 114 | 115 | ``` 116 | 117 | 118 | ### Hooks for interactive use 119 | 120 | Programs using 3bgl-shader can add a function to 121 | `3bgl-shaders::*modified-function-hook*`, which will be called when 122 | shader functions are redefined. It will be passed a list of names of 123 | updated functions. For example in the shaders above, if the 124 | `(defconstant +scale+ 2.0 :float)` form were recompiled in slime with 125 | `C-c C-c`, the hook functions would be passed the list 126 | `(SHADER::INVERTED-FRAGMENT SHADER::INVERT-AND-SCALE)` since 127 | `invert-and-scale` depends on the constant, and `inverted-fragment` 128 | depends on the function `invert-and-scale`. The hook function could 129 | then see one of the fragment shaders it is using had been modified, 130 | and arrange for a running program to try to recompile the shader 131 | program next frame. 132 | 133 | 134 | ### Current status 135 | 136 | The compiler and type inference mostly work, including some fairly 137 | complicated shaders. 138 | 139 | Built-in functions/types/variables from glsl version 4.50 are 140 | available, and older versions might work to the extent they are 141 | compatible with the subset of 4.50 used in a particular shader. The 142 | type inference doesn't distinguish between versions, so might allow 143 | casts that wouldn't be valid in an older version. 144 | 145 | Error messages are mostly horrible, so most type inference failures 146 | will give incomprehensible errors. 147 | 148 | CL style type declarations are allowed and should mostly be respected. 149 | 150 | API isn't completely finished, so some parts may change (in particular 151 | the base types like `:vec3` may be renamed to `3bgl-glsl:vec3` at some 152 | point.) 153 | 154 | The external API needs more work, in particular some way to query 155 | uniforms, inputs, outputs, etc. 156 | 157 | Currently no way to translate line/column numbers from glsl error 158 | messages back to source. 159 | 160 | Performance is acceptable for shaders I've tested it on, but not sure 161 | how it scales. It currently `WARN`s if it takes more than 2000 passes 162 | for type inference, which may need adjusted or disabled for larger shaders. 163 | 164 | Currently all functions that depend on a function/global will be 165 | recompiled when things they depend on are recompiled, which can make 166 | changing function signatures or types difficult if they aren't 167 | compatible with the uses. 168 | 169 | Recompilation may be more aggressive than it needs to be, for 170 | example if the value of a constant is changed, it shouldn't need to 171 | re-run type inference of functions that use that constant if the type 172 | didn't change. 173 | 174 | Dependencies on uniforms are sometimes missed, dumping a bare 175 | reference to it in main function is a simple workaround. 176 | 177 | ### Misc notes 178 | 179 | #### Concrete types 180 | 181 | GLSL types are currently named with keywords (though that may change 182 | in the future), like `:vec2`, `:vec3`, `:vec4`, `:mat2x4`, 183 | `:sampler-2d-array-shadow` etc. see [the 184 | source](https://github.com/3b/3bgl-shader/blob/master/types.lisp#L356-L476) 185 | for details for now, though most are fairly obvious. 186 | 187 | #### Component swizzles 188 | 189 | Components of GLSL vector types like `:vec4` can be accessed with 190 | 'swizzle' functions like `.xyz`, so for example glsl `someVec.rraa` 191 | would be `(.rraa some-vec)`. Type inference should correctly use the 192 | swizzle to determine minimum size of the vector if not specified. 193 | 194 | #### Structure/interface slots 195 | 196 | `(@ var slot-name)` is a shortcut for `(slot-value var 'slot-name)`, 197 | and either will compile to `var.slot`. GLSL doesn't allow specifying a 198 | slot through a variable, so slot name must be a quoted compile-time 199 | literal. 200 | 201 | #### RETURN 202 | 203 | Functions are required to use `RETURN` to return values, they will not 204 | return the value of the last form as in CL. A function without a 205 | `RETURN` will have a `void` return type. `(return (values))` can also 206 | be used to force a `void` return type, and for early exit from a 207 | `void` function. 208 | 209 | #### Overloaded functions 210 | 211 | If a function doesn't have a specific derived or specified type, it 212 | can be used with any compatible types, and the generated GLSL will 213 | have a version for each type. 214 | 215 | For example the previous code could have had 216 | 217 | ```Lisp 218 | 219 | ;; X can be any type that works with scalar `*` and `-` 220 | (defun invert-and-scale (x) 221 | (return (* +scale+ (- 1 x)))) 222 | 223 | (defun inverted-fragment () 224 | (setf out-color (+ (invert-and-scale 1) ;; call 'int' version 225 | (invert-and-scale (@ ins color))))) ;; call 'vec4' version 226 | ``` 227 | 228 | which would generate the glsl code 229 | 230 | ```glsl 231 | #version 450 232 | out vec4 outColor; 233 | 234 | const float SCALE = 2.0; 235 | in varyings { 236 | vec4 color; 237 | } ins; 238 | 239 | // returns a vec4 because the input is vec4 240 | vec4 invertAndScale (vec4 x) { 241 | return (SCALE * (1 - x)); 242 | } 243 | 244 | // returns float because SCALE is a float 245 | float invertAndScale (int x) { 246 | return (SCALE * (1 - x)); 247 | } 248 | 249 | void main () { 250 | outColor = (invertAndScale(1) + invertAndScale(ins.color)); 251 | } 252 | ``` 253 | 254 | #### Type declarations 255 | 256 | CL-style type declarations are allowed, and should interact correctly 257 | with type inference. 258 | 259 | for example 260 | 261 | ```Lisp 262 | (defun foo (x y) 263 | (declare (values :float) (:float x)) 264 | (let ((a (+ x y))) 265 | (declare (:vec2 a)) 266 | (return (.x a)))) 267 | ``` 268 | 269 | specifies that `foo` returns a `float`, the first argument is also 270 | specified to be `float`, while the second isn't explicitly 271 | restricted. The local variable `A` is specified to be a `vec2`, which 272 | implicitly restricts `Y` to also be something that casts to `vec2`. 273 | 274 | `(declare (values))` can be used to explicitly specify `void` return 275 | type for a function. 276 | 277 | 278 | #### Uniforms, input, output, interface 279 | 280 | Uniforms are specified with `(UNIFORM name type &key stage location layout qualifiers)`. 281 | `:stage` specifies in which shader stages (`:vertex`,`:fragment` etc) 282 | the uniform is visible (by default the uniform is visible in all 283 | stages, though will only be included in generated GLSL for stages in 284 | which it is referenced). 285 | `:location N` is a shortcut for specifying the `location` layout qualifier. 286 | `:layout (...)` allows specifying arbitrary layout qualifiers, argument is a plist containing qualifier and value (specify value = `t` for qualifiers that don't take arguments) 287 | `:qualifiers (...)` allows specifying other qualifiers like `restrict`, argument is a list of qualifiers. 288 | 289 | ```Lisp 290 | ;; a simple 'int' uniform, location chosen by driver or GL side of API 291 | (uniform flag :int) 292 | ;; -> uniform int flag; 293 | 294 | ;; an image2D uniform, with format, location and `restrict` specified 295 | (uniform tex :image-2d :location 1 :layout (:rg32f t) :qualifiers (:restrict)) 296 | ;; -> layout(location = 1,rg32f) uniform restrict image2D tex; 297 | 298 | ;; an atomic counter, with binding and offset specified 299 | (uniform counter :atomic-uint :layout (:binding 0 :offset 0)) 300 | ;; -> layout(binding = 0,offset = 0) uniform atomic_uint counter; 301 | 302 | ``` 303 | 304 | Inputs and outputs are specified with `(INPUT name type &key stage location)` 305 | and `(OUTPUT name type &key stage location)` 306 | where `stage` specifies in which shader stages (`:vertex`,`:fragment` 307 | etc) the input is visible, and `location` is an integer which will be 308 | output as `layout(location = 1)` in GLSL. 309 | 310 | Interfaces between stages are specified as `(INTERFACE name (&key in 311 | out uniform) &body slots)`. `slots` is a list of `(slot-name 312 | type)`. `in`, `out` and `uniform` specify how the interface will be 313 | visible, and are either `T` to make it visible to all stages as 314 | `name`, or a plist of stage names and names to use for the interface in that stage. 315 | 316 | For example `(interface varyings (:out (:vertex outs) :in (:fragment 317 | ins :geometry (ins "ins" :*))) ...)` will be visible as an output 318 | named `out` in the vertex shader, as an input array named `ins` in the 319 | geometry shader, and as an input named `ins` in the fragment shader. 320 | 321 | 322 | `name` and `slot-name` in uniform/input/output/interface can either be 323 | a symbol which will be automatically converted from `lisp-style` to 324 | `glslStyle`, or it can be a list of `(lisp-name "glslName")` to 325 | provide an explicit translation. 326 | 327 | 328 | #### Running the example programs 329 | 330 | Example program uses GLUT and GLU, and expects GLSL version 330. 331 | Most lisp dependencies should be available in quicklisp, aside from possibly [mathkit](https://github.com/lispgames/mathkit). 332 | 333 | Load `3bgl-shader-example.asd` through ASDF or Quicklisp, then run 334 | `(3bgl-shader-example:run-example)`. That should create a window with 335 | a spinning teapot, hit `0`-`5` keys to try the various example 336 | shaders. 337 | 338 | If that is working, you can open example-shaders.lisp in emacs and 339 | edit them and recompile as usual from slime (C-c C-c etc). 340 | 341 | 342 | #### Getting names of uniforms/vertex attributes 343 | 344 | In addition to generated GLSL source, `GENERATE-STAGE` returns a list 345 | of uniforms as 2nd value, and attributes in 3rd value. Both are in 346 | form `(lisp-name "glslName" TYPE)` for each entry. There isn't 347 | currently any dead-code elimination, so listed names may not actually 348 | be active in the final shader program. 349 | 350 | 351 | #### Macros 352 | 353 | `DEFMACRO` and `MACROLET` work as in CL code, and expansion runs on 354 | host so can use arbitrary CL. 355 | 356 | #### Array variables 357 | 358 | There is partial support for arrays, though type inference doesn't 359 | work completely correctly on them and local array variables can't be 360 | initialized when bound. 361 | 362 | Currently, array types are specified as `( )`. (CL 363 | style array/vector types may be supported at some point in the future) 364 | 365 | ```Lisp 366 | (defun foo () 367 | (let ((a)) ;; can't currently initialize local array variables 368 | (declare ((:float 8) a)) ;; specify size/base type 369 | (setf (aref a 1) 1.23) ;; access as in CL 370 | (return (aref a 1))) 371 | ``` 372 | 373 | #### Compute Shaders 374 | 375 | Compute shaders work pretty much like other stages, except you can't 376 | specify `input`s/`output`s, and must specify the workgroup size for 377 | kernel invocations. The workgroup sizes are specified with the 378 | `layout` declaration on the main kernel entrypoint. Compute shaders 379 | also expose a number of constants describing an individual 380 | invocation's relationship to the entire run: `gl-local-invocation-id`, `gl-global-invocation-id`, `gl-work-group-id`, `gl-num-work-groups`, and `gl-work-group-size`, all `:uvec3`, and `gl-local-invocation-index`, an `:int`. 381 | 382 | ```Lisp 383 | ;; define a kernel that runs in units of 8x8x8 blocks 384 | (defun some-kernel () 385 | (declare (layout (:in nil :local-size-x 8 :local-size-y 8 :local-size-z 8))) 386 | ;; xyz takes values from (uvec3 0 0 0) to (uvec3 7 7 7) 387 | (let ((xyz (.xyz gl-local-invocation-id))) 388 | ...)) 389 | ``` 390 | 391 | 392 | #### Shared variables in compute shaders 393 | 394 | Compute shader `shared` variables are defined with `SHARED`, which 395 | takes a name and type (including array types) as arguments 396 | 397 | ```Lisp 398 | ;; define a shared array with 256 :float elements 399 | ;; can be accessed with (aref temp x) or (setf (aref temp x) ...) as in CL 400 | (shared temp (:float 256)) 401 | ;; a shared uint 402 | (shared foo :uint) 403 | ``` 404 | 405 | #### Shader Storage Buffer Objects 406 | 407 | Limited support for SSBO, use `(interface (:buffer t) ...)` 408 | 409 | ```Lisp 410 | ;; makes FOO and BAR available in shaders for read/write 411 | ;; BAR is an array of mat4, size depends on size of bound buffer 412 | (interface ssbo (:buffer t :layout (:binding 0 :std430 t)) 413 | (foo :vec4) 414 | (bar (:mat4 :*))) 415 | ``` 416 | 417 | 418 | #### Structures 419 | 420 | Preliminary support for defining structures with |defstruct|, doesn't 421 | currently accept any of the extra options from |cl:defstruct|, and 422 | slot syntax is |(slot-name type)|. 423 | 424 | Can't currently infer type of structs, so need to |declare| them by hand. 425 | 426 | ```Lisp 427 | ;; define a struct with a float, array of 8 int, and arbitrary 428 | ;; length array of vec4 429 | (defstruct foo 430 | (a :float) 431 | (b (:int 8)) 432 | (c (:vec4 :*))) 433 | ``` 434 | -------------------------------------------------------------------------------- /api.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | 3 | ;; calling generate-stage while compile-form is running might see an 4 | ;; inconsistent stage, and is reasonably likely when compiling a whole 5 | ;; file if calling code doesn't wait a while before calling 6 | ;; generate-stage. Doesn't seem to be any reaonable way to determine 7 | ;; how long to wait, so adding a lock so at worst we just get 8 | ;; redundant shader recompiles instead of errors. 9 | (defparameter *compiler-lock* (bordeaux-threads:make-lock 10 | "3bgl-shaders:compile-form")) 11 | 12 | (defvar *modified-function-hook* nil 13 | "list of functions to call when shader functions are 14 | modified. Passed a list of names of functions that have been 15 | modified. May be called multiple times for same function if a whole 16 | file using the 3bgl-glsl:defun macro is recompiled, so probably should 17 | store names and only update shader programs at next frame rather 18 | than updating programs directly from hook function.") 19 | 20 | (defvar *default-version* 450) 21 | (defvar *default-extensions* nil) ;; exact strings or like :arb-some-extension 22 | 23 | ;; compiler entry points 24 | 25 | ;; first pass of compilation for one or more forms 26 | ;; (expand macros, partial type inference, update dependencies, etc) 27 | (defun compile-form (form) 28 | "Run first passes of compilation on specified form. (Wrap with PROGN 29 | to process multiple forms). Calls functions in 30 | *MODIFIED-FUNCTION-HOOK* with names of any functions whose definitions 31 | are possibly affected by compiling FORM (for example functions that 32 | call a function defined/updated by FORM, and the (re)defined function 33 | itself). " 34 | (let ((modified-function-names nil)) 35 | (bordeaux-threads:with-lock-held (*compiler-lock*) 36 | (3bgl-glsl::with-package-environment () 37 | (let ((*new-function-definitions* nil) 38 | (*new-type-definitions* nil) 39 | (*new-global-definitions* nil)) 40 | ;; 'compile' forms 41 | (walk form (make-instance 'extract-functions)) 42 | ;; update dependencies for any (re)defined functions 43 | (loop for f in *new-function-definitions* 44 | do (update-dependencies f)) 45 | (loop for (nil f) in *new-global-definitions* 46 | do (update-dependencies f)) 47 | ;; if any functions' lambda list was changed, recompile any 48 | ;; calls to those functions in their dependents 49 | (let* ((changed-signatures (remove-if-not #'function-signature-changed 50 | *new-function-definitions*)) 51 | (deps (make-hash-table)) 52 | (update-calls (make-instance 'update-calls 53 | :modified 54 | (alexandria:alist-hash-table 55 | (mapcar (lambda (a) 56 | (cons a nil)) 57 | changed-signatures))))) 58 | (loop for i in changed-signatures 59 | do (maphash (lambda (k v) (setf (gethash k deps) v)) 60 | (bindings-using i)) 61 | (setf (old-lambda-list i) 62 | (lambda-list i))) 63 | (maphash (lambda (k v) 64 | (declare (ignore v)) 65 | (walk k update-calls)) 66 | deps)) 67 | (let ((modified-deps (make-hash-table))) 68 | (loop for (nil i) in *new-type-definitions* 69 | for deps = (bindings-using i) 70 | do (loop for i being the hash-keys of deps 71 | when (typep i 'global-function) 72 | do (setf (gethash i modified-deps) t))) 73 | (loop for (nil i) in *new-global-definitions* 74 | for deps = (bindings-using i) 75 | do (loop for i being the hash-keys of deps 76 | when (typep i 'global-function) 77 | do (setf (gethash i modified-deps) t))) 78 | (loop for i in *new-function-definitions* 79 | do (setf (gethash i modified-deps) t)) 80 | (when *verbose* 81 | (format t "deps = ~s~%" (mapcar 'name (alexandria:hash-table-keys modified-deps)))) 82 | (when (plusp (hash-table-count modified-deps)) 83 | (let ((modified (infer-modified-functions 84 | (alexandria:hash-table-keys modified-deps)))) 85 | (assert modified) 86 | (loop for f in modified 87 | do (pushnew (name f) modified-function-names))))) 88 | 89 | (when *verbose* 90 | (format t "modified functions: ~s~%" modified-function-names) 91 | (format t "modified types: ~s~%" *new-type-definitions*) 92 | (format t "modified globals: ~s~%" *new-global-definitions*))))) 93 | ;; call hook outside lock in case it tries to call generate-stage 94 | (map nil (lambda (a) (funcall a modified-function-names)) 95 | *modified-function-hook*) 96 | nil)) 97 | 98 | (defun expand-extension-keyword (ext) 99 | (if (stringp ext) 100 | ext 101 | (let* ((s (substitute #\_ #\- (symbol-name ext))) 102 | (p (position #\_ s))) 103 | (format nil "GL_~:@(~a~)~(~a~)" (subseq s 0 p) (subseq s p))))) 104 | 105 | (defmethod generate-output (objects inferred-types (backend (eql :glsl)) 106 | &key version extensions &allow-other-keys) 107 | (with-output-to-string (*standard-output*) 108 | (format t "#version ~a~%" version) 109 | (loop for .ext in extensions 110 | for ext = (if (consp .ext) (first .ext) .ext) 111 | for enable = (if (consp .ext) (second .ext) t) 112 | do (format t "#extension ~a : ~a~%" 113 | (expand-extension-keyword ext) 114 | (if enable "enable" "disable"))) 115 | (when (eql *current-shader-stage* :vertex) 116 | (format t "invariant gl_Position;~%")) 117 | ;; put layout() at beginning for compute stage 118 | (when (and (eql *current-shader-stage* :compute) 119 | (layout-qualifiers *print-as-main*)) 120 | (print-main-layout-qualifiers (layout-qualifiers *print-as-main*))) 121 | 122 | (loop with dumped = (make-hash-table) 123 | for object in objects 124 | for stage-binding = (stage-binding object) 125 | for interface-block = (when stage-binding 126 | (interface-block stage-binding)) 127 | unless (and interface-block (gethash interface-block dumped)) 128 | do (etypecase object 129 | ((or generic-type interface-binding constant-binding) 130 | (unless (internal object) 131 | (pprint-glsl object) 132 | (when interface-block 133 | (setf (gethash interface-block dumped) t)))) 134 | (global-function 135 | (let ((overloads (gethash object inferred-types))) 136 | (assert overloads) 137 | (loop for overload in overloads 138 | for *binding-types* 139 | = (gethash overload 140 | (final-binding-type-cache 141 | object)) 142 | do (assert *binding-types*) 143 | (pprint-glsl object)))))))) 144 | 145 | (defparameter *default-backend* :glsl) 146 | 147 | (defparameter *shader-type->stage* 148 | (alexandria:plist-hash-table 149 | '(:vertex-shader :vertex 150 | :fragment-shader :fragment 151 | :geometry-shader :geometry 152 | :tess-control-shader :tess-control))) 153 | 154 | (defmethod expand-uniform-slots (prefix (b binding)) 155 | (append (expand-uniform-slots prefix (value-type b)))) 156 | 157 | (defmethod expand-uniform-slots (prefix (type struct-type)) 158 | (loop for slot in (bindings type) 159 | for slot-name = (name slot) 160 | for slot-type = (value-type slot) 161 | append (expand-uniform-slots (cons slot-name prefix) slot-type))) 162 | 163 | (defmethod expand-uniform-slots (prefix (type concrete-type)) 164 | (list (reverse prefix))) 165 | 166 | (defmethod expand-uniform-slots (prefix (type array-type)) 167 | (let ((size (array-size type))) 168 | (etypecase size 169 | (number 170 | (loop for i below size 171 | append (expand-uniform-slots (cons i prefix) (base-type type)))) 172 | (constant-binding 173 | (unless (numberp (initial-value-form size)) 174 | (error "can't expand constant ~s = ~s when generating uniforms" 175 | (name size) (initial-value-form size))) 176 | (loop for i below (initial-value-form size) 177 | append (expand-uniform-slots (cons i prefix) (base-type type)))) 178 | ((eql :*) 179 | (cons '[] prefix))))) 180 | 181 | 182 | (defun expand-uniforms (uniforms expand) 183 | (loop for u in uniforms 184 | for sb = (stage-binding u) 185 | for b = (binding sb) 186 | collect (list* (name u) (translate-name u) 187 | (name (if (typep b 'binding) 188 | (value-type b) 189 | b)) 190 | (when expand 191 | (list :components 192 | (expand-uniform-slots (list (name u)) 193 | (binding sb))))))) 194 | 195 | (defun expand-buffers (buffers) 196 | (let ((blocks (delete-duplicates 197 | (loop for b in buffers 198 | collect (stage-binding b)) 199 | :test 'equalp 200 | :key 'interface-block))) 201 | (loop for block in blocks 202 | for ib = (interface-block block) 203 | for lq = (layout-qualifier block) 204 | collect (list* (name ib) 205 | (translate-name ib) 206 | (list :layout lq 207 | :components 208 | (when ib 209 | (loop for b in (bindings ib) 210 | collect (list (name b) 211 | (name (if (typep b 'binding) 212 | (value-type b) 213 | b)))))))))) 214 | 215 | (defun expand-structs (structs) 216 | (loop for struct in structs 217 | collect (list* (name struct) 218 | (translate-name struct) 219 | (list :components 220 | (loop for b in (bindings struct) 221 | collect (list (name b) 222 | (name (if (typep b 'binding) 223 | (value-type b) 224 | b)))))))) 225 | 226 | ;; final pass of compilation 227 | ;; finish type inference for concrete types, generate glsl 228 | (defun generate-stage (stage main &key (backend *default-backend*) 229 | (version *default-version*) 230 | (extensions *default-extensions*) 231 | (expand-uniforms)) 232 | "Generate GLSL shader for specified STAGE, using function named by 233 | MAIN as glsl 'main' function. ROOT and all functions/variables/etc it 234 | depends on should already have been successfully compiled with 235 | COMPILE-FORM. STAGE is :VERTEX, :FRAGMENT, :GEOMETRY, :TESS-EVAL, 236 | :TESS-CONTROL, or :COMPUTE. VERSION specifies the value of the version 237 | pragma in generated shader, but doesn't otherwise affect generated 238 | code currently. Returns a list of active uniforms in the 239 | form (LISP-NAME \"glslName\" type . PROPERTIES) as second value, and a 240 | list of active attributes in same format as third value. (GL shader 241 | types like :VERTEX-SHADER are also accepted for STAGE) 242 | 243 | For uniforms, PROPERTIES is a plist containing 0 or more of: 244 | 245 | :COMPONENTS : (when EXPAND-UNIFORMS is true) for composite 246 | uniforms (structs, etc), a list containing a list of uniform name and 247 | slot names or array indices for each leaf uniform represented by the 248 | type, for example a struct uniform containing an array of structs 249 | might have entries that look like (foo bar 1 baz) corresponding to the 250 | uniform \"foo.bar[1].baz\". 251 | 252 | 253 | " 254 | ;; todo: add location, layout, binding, UBO/SSBO, etc for uniforms 255 | (setf stage (gethash stage *shader-type->stage* stage)) 256 | (bordeaux-threads:with-lock-held (*compiler-lock*) 257 | (3bgl-glsl::with-package-environment (main) 258 | (let* ((*print-as-main* (get-function-binding main)) 259 | (*current-shader-stage* stage) 260 | (uniforms) 261 | (buffers) 262 | (attributes) 263 | (structs)) 264 | (let ((shaken (tree-shaker main))) 265 | (let ((inferred-types 266 | (finalize-inference (get-function-binding main)))) 267 | #++(format t "~%~&~&generate-stage: main = ~s~%" main) 268 | #++(format t "shaken = ~s~%" shaken) 269 | (loop for s in shaken 270 | for i = (when (typep s 'interface-binding) 271 | (stage-binding s)) 272 | when (typep s 'struct-type) 273 | do (push s structs) 274 | when i 275 | do #++(format t " ~s binding ~s / ~s = ~s~%" 276 | (interface-qualifier i) 277 | (name s) (translate-name s) 278 | (name (binding i))) 279 | (case (if (consp (interface-qualifier i)) 280 | (car (interface-qualifier i)) 281 | (interface-qualifier i)) 282 | (:uniform 283 | #++(pushnew (list (name s) (translate-name s) 284 | (name (binding i))) 285 | uniforms :test 'equal) 286 | (pushnew s uniforms :test 'equal)) 287 | (:buffer 288 | (pushnew s buffers :test 'equal)) 289 | (:in 290 | (when (eq stage :vertex) 291 | (pushnew (list (name s) (translate-name s) 292 | (name (binding i))) 293 | attributes :test 'equal))))) 294 | ;(break "shaken" shaken) 295 | (values 296 | (generate-output shaken inferred-types backend 297 | :version version :extensions extensions) 298 | (expand-uniforms uniforms expand-uniforms) 299 | attributes 300 | (expand-buffers buffers) 301 | (expand-structs structs)))))))) 302 | 303 | 304 | 305 | 306 | (in-package #:3bgl-glsl) 307 | ;;; CL macros for the glsl API (for use with slime when working on files 308 | ;;; to be loaded as glsl code) 309 | 310 | (cl:defmacro defun (name args &body body) 311 | `(3bgl-shaders::compile-form '(cl:defun ,name ,args ,@body))) 312 | 313 | (cl:defmacro defmacro (name args &body body) 314 | `(3bgl-shaders::compile-form '(cl:defmacro ,name ,args ,@body))) 315 | 316 | (cl:defmacro defconstant (name value type) 317 | `(3bgl-shaders::compile-form '(%defconstant ,name ,value ,type))) 318 | 319 | (cl:defmacro defstruct (name &rest slots) 320 | `(3bgl-shaders::compile-form '(cl:defstruct ,name ,@slots))) 321 | 322 | (cl:defmacro interface (name (&rest args &key in out uniform buffer 323 | layout) 324 | &body slots) 325 | (declare (ignore in out uniform buffer layout)) 326 | `(3bgl-shaders::compile-form '(interface ,name ,args ,@slots))) 327 | 328 | (cl:defmacro attribute (name type &rest args &key location) 329 | (declare (ignore location)) 330 | `(3bgl-shaders::compile-form '(attribute ,name ,type ,@args))) 331 | 332 | (cl:defmacro input (name type &rest args &key stage location qualifiers) 333 | (declare (ignore location stage)) 334 | `(3bgl-shaders::compile-form '(input ,name ,type ,@args))) 335 | 336 | (cl:defmacro output (name type &rest args &key stage location qualifiers) 337 | (declare (ignore location stage)) 338 | `(3bgl-shaders::compile-form '(output ,name ,type ,@args))) 339 | 340 | (cl:defmacro uniform (name type &rest args &key stage location internal layout 341 | qualifiers default 342 | &allow-other-keys) 343 | (declare (ignore location stage internal layout qualifiers default)) 344 | `(3bgl-shaders::compile-form '(uniform ,name ,type ,@args))) 345 | 346 | (cl:defmacro shared (name type &rest args &key stage layout qualifiers 347 | &allow-other-keys) 348 | (declare (ignore stage layout qualifiers)) 349 | `(3bgl-shaders::compile-form '(shared ,name ,type ,@args))) 350 | 351 | (cl:defmacro bind-interface (stage block-name interface-qualifier instance-name) 352 | `(3bgl-shaders::compile-form '(bind-interface ,stage ,block-name 353 | ,interface-qualifier ,instance-name))) 354 | 355 | ;;; glsl versions for use when whole file is processed directly 356 | (%glsl-macro defun (name args &body body) 357 | `(cl:defun ,name ,args ,@body)) 358 | 359 | 360 | 361 | ;; define cl:position as a vec4 vertex attribute at location 0, since 362 | ;; it is pretty common but can't be defined from user code with CL 363 | ;; package locked 364 | (3bgl-glsl::glsl-input position :vec4 :location 0) 365 | ;; and single-float pi as well 366 | (3bgl-glsl::glsl-defconstant pi #.(float pi 1.0) :float) 367 | 368 | ;; lock CL abd GLSL packages, so user packages can't define 369 | ;; conflicting globals with names in those packages 370 | (setf (3bgl-shaders::locked 3bgl-shaders::*cl-environment*) t 371 | (3bgl-shaders::locked 3bgl-glsl::*glsl-base-environment*) t) 372 | -------------------------------------------------------------------------------- /compiler.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | 3 | ;;; passes 4 | ;;; +base pass (expand macros, symbol macros, etc) 5 | ;; (possibly combined with next pass, since it probably inherits from 6 | ;; walker that does expansion already) 7 | ;;; +extract top-level definitions 8 | ;;; +inline local functions? 9 | ;; has to happen after alpha conversion, since free variables 10 | ;; in the local function bodies need to refer to bindings in the 11 | ;; scope when the function was defined, as opposed to when it was 12 | ;; called 13 | ;;; alpha conversion? 14 | ;;; (including resolving conflicts between fn/var/etc namespaces?) 15 | ;; if possible, it would be nice to leave names unchanged, and 16 | ;; rely on on {} for shadowing lexical scopes, but if so, we need 17 | ;; to watch out for inlined local closures 18 | 19 | ;;; convert into some less-cl form? 20 | ;;; tree of objects (or just plists)? 21 | ;;; constant folding? 22 | ;;; (partial) type inference for secondary functions 23 | ;; for anything that isn't the main function, we allow parameters 24 | ;; and return types to be not fully determined, and later try to 25 | ;; generate overloads for any variants actually used after tree shaker 26 | ;;; type inference on main function 27 | ;;; +tree shaker 28 | ;; possibly before any type inference? depends on if we are keeping 29 | ;; secondary functions around for multiple compiles (which we probably 30 | ;; want to do, for libs and such) 31 | ;;; generate specialized versions of any partially types functions 32 | ;;; generate code 33 | 34 | 35 | ;;; first pass: expand macros, extract function definitions into environments 36 | ;;; (should basically just leave variable definitions/initialization?) 37 | (defclass extract-functions (3bgl-glsl::glsl-walker) 38 | ()) 39 | 40 | ;;; list of new functions (used to tell which functions were just 41 | ;;; defined and need things like dependencies added and type 42 | ;;; inference by later passes) 43 | (defvar *new-function-definitions*) 44 | (defvar *new-type-definitions*) 45 | (defvar *new-global-definitions*) 46 | (defvar *function-stages*) 47 | 48 | (defwalker extract-functions (defun name lambda-list &body body+d) 49 | (multiple-value-bind (body declare doc) 50 | (alexandria:parse-body body+d :documentation t) 51 | (let* ((3bgl-glsl::*current-function* 52 | (process-type-declarations-for-scope 53 | (add-function name lambda-list 54 | nil 55 | :declarations declare :docs doc))) 56 | (*function-stages* (valid-stages 3bgl-glsl::*current-function*))) 57 | (clrhash (bindings-used-by 3bgl-glsl::*current-function*)) 58 | (when (boundp '*new-function-definitions*) 59 | (pushnew 3bgl-glsl::*current-function* *new-function-definitions*)) 60 | (setf (body 3bgl-glsl::*current-function*) 61 | (with-lambda-list-vars (3bgl-glsl::*current-function*) (@@ body))) 62 | ;; if *function-stages* is NIL, we got bindings that only exist 63 | ;; in disjoint sets of stages... 64 | (assert *function-stages*) 65 | (setf (valid-stages 3bgl-glsl::*current-function*) 66 | (alexandria:ensure-list *function-stages*))) 67 | nil)) 68 | 69 | (macrolet ((track-globals (&rest forms) 70 | `(progn 71 | ,@(loop for form in forms 72 | collect 73 | `(defwalker extract-functions (,form name &rest rest) 74 | (declare (ignore rest)) 75 | (prog1 76 | (call-next-method) 77 | (when (boundp '*new-global-definitions*) 78 | (when (consp name) 79 | (setf name (car name))) 80 | (assert (get-variable-binding name)) 81 | (pushnew (list name (get-variable-binding name)) 82 | *new-global-definitions*)))))))) 83 | (track-globals defconstant defparameter 84 | 3bgl-glsl:defconstant 3bgl-glsl::%defconstant 85 | 3bgl-glsl:attribute 3bgl-glsl:uniform 86 | 3bgl-glsl:input 3bgl-glsl:output 87 | 3bgl-glsl:bind-interface)) 88 | 89 | (macrolet ((track-types (&rest forms) 90 | `(progn 91 | ,@(loop for form in forms 92 | collect 93 | `(defwalker extract-functions (,form name &rest rest) 94 | (declare (ignore rest)) 95 | (prog1 96 | (call-next-method) 97 | (when (boundp '*new-type-definitions*) 98 | (pushnew (list name (get-type-binding name)) 99 | *new-type-definitions*)))))))) 100 | (track-types defstruct)) 101 | 102 | 103 | 104 | 105 | (defmethod check-stages (interface-binding) 106 | (let ((types 107 | (loop for (nil sb) on (stage-bindings interface-binding) by #'cddr 108 | ;; don't check for conflicts in IN/OUT for now 109 | for .iq = (interface-qualifier sb) 110 | for iq = (if (consp .iq) 111 | (remove-if (lambda (a) (member a '(:in :out))) 112 | .iq) 113 | (if (member .iq '(:in :out)) 114 | nil 115 | .iq)) 116 | when iq 117 | collect (binding sb)))) 118 | (unless (or (every (lambda (a) (typep a 'interface-type)) 119 | types) 120 | (every (lambda (a) (eq a (car types))) 121 | (cdr types))) 122 | (error "conflicting types for interface binding ~s : ~{~s~^ ~}" 123 | (name interface-binding) 124 | (remove-duplicates(mapcar 'name types)))))) 125 | 126 | (defmethod check-slot-stages (slot-access) 127 | (labels ((get-interface-bindings (x) 128 | (etypecase x 129 | ((or slot-access variable-read variable-write array-access) 130 | (get-interface-bindings (binding x))) 131 | (interface-binding 132 | x) 133 | (local-variable 134 | (return-from check-slot-stages t))))) 135 | (let* ((interface-bindings (get-interface-bindings slot-access)) 136 | (types 137 | (loop for (nil sb) on (stage-bindings interface-bindings) by #'cddr 138 | for b = (binding sb) 139 | for st = (if (typep b 'interface-type) 140 | (find (field slot-access) 141 | (bindings b) 142 | :key #'name) 143 | b) 144 | when st 145 | collect (value-type st)))) 146 | (unless (every (lambda (a) (eq a (car types))) 147 | (cdr types)) 148 | (error "conflicting types for slot ~s.~s : ~{~s~^ ~}" 149 | (name interface-bindings) (field slot-access) 150 | (remove-duplicates(mapcar 'name types))))))) 151 | 152 | (defmethod walk :around (form (walker extract-functions)) 153 | (let ((r (call-next-method))) 154 | (when (typep r 'slot-access) 155 | (check-slot-stages r)) 156 | (when (or (typep r 'variable-read) 157 | (typep r 'variable-write)) 158 | (when (typep (binding r) 'interface-binding) 159 | (check-stages (binding r)) 160 | (let ((stage-bindings (stage-bindings (binding r)))) 161 | (unless (getf stage-bindings t) 162 | (let ((stages (loop for s in stage-bindings by #'cddr 163 | collect s))) 164 | (if (or (eq t *function-stages*) 165 | (equalp '(t) *function-stages*)) 166 | (setf *function-stages* stages) 167 | (setf *function-stages* 168 | (intersection *function-stages* stages)))))))) 169 | r)) 170 | 171 | ;;;; tree-shaker 172 | ;;; given an entry point, return a list of all functions called by that 173 | ;;; entry point, in reverse dependency order (so main entry point last) 174 | ;; 175 | ;; we also need to declare any aggregate types we use, so we need to 176 | ;; mark variable usage, then map those back to structure/interface 177 | ;; types and dump those as well 178 | ;(defparameter *tree-shaker-live* nil) 179 | ;(defparameter *tree-shaker-depth* 0) 180 | ;(defparameter *tree-shaker-roots* nil) 181 | (defparameter *tree-shaker-hook* (lambda (&rest r) (declare (ignore r)))) 182 | (defparameter *tree-shaker-type-hook* (lambda (&rest r) (declare (ignore r)))) 183 | (defparameter *tree-shaker-current-object* nil) 184 | ;; fixme: rename this stuff, since tree-shaker doesn't use it anymore 185 | (defclass tree-shaker () 186 | ()) 187 | 188 | (defmethod walk ((form cons) (walker tree-shaker)) 189 | (flet ((w (x) 190 | (walk x walker))) 191 | (map nil #'w form))) 192 | 193 | (defmethod walk ((form function-call) (walker tree-shaker)) 194 | (when (or (typep (called-function form) 'global-function) 195 | (typep (called-function form) 'unknown-function-binding)) 196 | (funcall *tree-shaker-hook* (called-function form))) 197 | (call-next-method)) 198 | 199 | (defmethod walk ((form (eql t)) (walker tree-shaker)) 200 | ;; for unspecified declared types 201 | form) 202 | (defmethod walk ((form (eql :*)) (walker tree-shaker)) 203 | ;; for unspecified array size 204 | form) 205 | 206 | (defmethod walk ((form concrete-type) (walker tree-shaker)) 207 | form) 208 | 209 | (defmethod walk ((form slot-access) (walker tree-shaker)) 210 | (walk (binding form) walker) 211 | (call-next-method)) 212 | 213 | (defmethod walk ((form variable-read) (walker tree-shaker)) 214 | (walk (binding form) walker) 215 | (call-next-method)) 216 | 217 | (defmethod walk ((form variable-write) (walker tree-shaker)) 218 | (walk (binding form) walker) 219 | (call-next-method)) 220 | 221 | (defmethod walk ((form swizzle-access) (walker tree-shaker)) 222 | (walk (binding form) walker) 223 | (call-next-method)) 224 | 225 | (defmethod walk ((form local-variable) (walker tree-shaker)) 226 | (walk (value-type form) walker) 227 | (walk (declared-type form) walker) 228 | (call-next-method)) 229 | 230 | (defmethod walk ((form binding) (walker tree-shaker)) 231 | (walk (declared-type form) walker) 232 | (walk (value-type form) walker) 233 | (call-next-method)) 234 | 235 | (defmethod walk ((form constant-binding) (walker tree-shaker)) 236 | (funcall *tree-shaker-type-hook* form) 237 | (call-next-method)) 238 | 239 | (defmethod walk ((form interface-binding) (walker tree-shaker)) 240 | (funcall *tree-shaker-type-hook* form) 241 | (let ((*tree-shaker-current-object* form)) 242 | (walk (stage-binding form) walker)) 243 | (call-next-method)) 244 | 245 | (defmethod walk ((form interface-stage-binding) (walker tree-shaker)) 246 | (walk (binding form) walker) 247 | (call-next-method)) 248 | 249 | (defmethod walk ((form struct-type) (walker tree-shaker)) 250 | (funcall *tree-shaker-type-hook* form) 251 | (let ((*tree-shaker-current-object* form)) 252 | (walk (bindings form) walker))) 253 | 254 | (defmethod walk ((form array-type) (walker tree-shaker)) 255 | (walk (base-type form) walker) 256 | (walk (array-size form) walker)) 257 | 258 | (defmethod walk ((form for-loop) (walker tree-shaker)) 259 | (walk (condition-forms form) walker) 260 | (walk (step-forms form) walker) 261 | (call-next-method)) 262 | 263 | ;; todo: rewrite this to use pregenerated dependencies? 264 | (defun tree-shaker (root) 265 | ;; we assume local functions have been inlined or extracted, and 266 | ;; names have been alpha converted as needed, etc already... 267 | (let* ((root (get-function-binding root))) 268 | (assert root) 269 | (reverse (topo-sort-dependencies root #'bindings-used-by)))) 270 | 271 | 272 | ;; add dependencies to specified function-binding-function 273 | ;; also add function as a dependent to any functions it depends on? 274 | (defun update-dependencies (form) 275 | ;; reuse tree-shaker walker, find all functions called and add to list 276 | ;; 277 | (assert (not (symbolp form))) 278 | (let* ((*tree-shaker-current-object* form) 279 | (*tree-shaker-hook* 280 | (lambda (f) 281 | (when (and (not (eq f *tree-shaker-current-object*)) 282 | (typep f 'binding-with-dependencies)) 283 | (setf (gethash f (bindings-used-by *tree-shaker-current-object*)) 284 | f) 285 | (setf (gethash *tree-shaker-current-object* (bindings-using f)) 286 | *tree-shaker-current-object*)))) 287 | (*tree-shaker-type-hook* 288 | (lambda (f) 289 | (when (and (not (eq f *tree-shaker-current-object*)) 290 | (typep f 'binding-with-dependencies)) 291 | (setf (gethash f (bindings-used-by *tree-shaker-current-object*)) 292 | f) 293 | (setf (gethash *tree-shaker-current-object* (bindings-using f)) 294 | *tree-shaker-current-object*))))) 295 | (walk *tree-shaker-current-object* (make-instance 'tree-shaker)))) 296 | 297 | (defclass update-calls (3bgl-glsl::glsl-walker) 298 | ((modified :initarg :modified :reader modified))) 299 | 300 | (defmethod walk ((form function-call) (walker update-calls)) 301 | (let ((*environment* (argument-environment form))) 302 | (setf (arguments form) 303 | (mapcar (lambda (x) 304 | (walk x walker)) 305 | (funcall (expander (called-function form)) 306 | (raw-arguments form))))) 307 | (call-next-method)) 308 | 309 | 310 | #++ 311 | (multiple-value-list 312 | (compile-block '((defun foo (a1 b1) 313 | (+ a (* 3 (/ b)) 2))) 314 | 'foo 315 | :vertex)) 316 | 317 | #++ 318 | (multiple-value-list 319 | (compile-block '((input position :vec4 :location 0) 320 | (defun foo (a1 b1) 321 | (+ a (* 3 (/ b)) 2))) 322 | 'foo 323 | :vertex)) 324 | 325 | 326 | #++ 327 | (multiple-value-list 328 | (compile-block '((defun foo (a b) 329 | (+ a (* 3 (/ b)) 2)) 330 | (defparameter *foo-bar* (+ 123 4)) 331 | (defconstant +hoge-piyo+ 45) 332 | (defmacro bar (c d) 333 | `(- ,c ,(+ d 10))) 334 | (defun not-called (g) 335 | (foo 1 2)) 336 | (defun calls-foo (a b) 337 | (foo a b)) 338 | (defun complicated (a &optional (b 1.0) &key (c 2 cp) 339 | (d 3)) 340 | (if cp (+ a b c) (+ a b))) 341 | (defun main () 342 | "do baz stuff" 343 | #++(flet ((a (b) 344 | (+ 1 b))) 345 | (a 2)) 346 | (let ((e) 347 | (f 1)) 348 | (when e 349 | (foo 1 2) 350 | (bar 2 3)) 351 | (if e 352 | (calls-foo (foo e 1) (bar f 9)) 353 | (complicated (if f (3bgl-glsl::<< f 1) (3bgl-glsl::>> e 1)) (3bgl-glsl::<< 4 +hoge-piyo+) 354 | :d 4))))) 355 | 'main 356 | :vertex)) 357 | 358 | #++ 359 | (multiple-value-list 360 | (compile-block '((defun a () (let ((aa 1.0)) 361 | 362 | (+ aa (b aa) (b 1) (c) (d)))) 363 | (defun a2 (a) (+ (b a) (c))) 364 | (defun b (bb) (+ (e) (f) bb)) 365 | (defun c () (b 2)) 366 | (defun d () (f)) 367 | (defun e () (d)) 368 | (defun f () (+ (g) (h))) 369 | (defun g () 1) 370 | (defun h () 2)) 371 | 'a 372 | :vertex)) 373 | 374 | 375 | #++ 376 | (3bgl-glsl::generate-stage :fragment 'skybox-shaders::fragment) 377 | #++ 378 | (print (3bgl-glsl::generate-stage :fragment '3bgl-mesh-shaders::fragment)) 379 | #++ 380 | (print (3bgl-glsl::generate-stage :geometry '3bgl-mesh-shaders::tsd-geometry)) 381 | 382 | -------------------------------------------------------------------------------- /example-shaders.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:3bgl-shader-example-shaders 2 | (:use #:3bgl-glsl/cl) 3 | (:export 4 | #:minimal-vertex 5 | #:minimal-fragment) 6 | ;; 3bgl-shader doesn't let you define globals named by symbols from 7 | ;; CL or 3bgl packages, so shadow TIME locally 8 | (:shadow #:time)) 9 | (in-package #:3bgl-shader-example-shaders) 10 | 11 | 12 | ;; vertex shader inputs, we specify :location so we don't have to 13 | ;; query the attributes from host code and can just use the specified 14 | ;; locations (CL:POSITION is predefined as :vec4 :location 0 since it 15 | ;; is pretty common to want that, so we can re-specify that exact 16 | ;; definition if we want to, but can't change it) 17 | (input position :vec4 :location 0) 18 | 19 | ;; if we were using modern GL, we would define some more vertex attributes 20 | ;; (input normal :vec3 :location 1) 21 | 22 | ;; for glutSolidTeapot we need to use the compatibility mode 23 | ;; attributes, so we specify the GLSL name of the fixed-function 24 | ;; vertex attributes instead of a location 25 | (input (normal "gl_Normal") :vec3) 26 | (input (uv "gl_MultiTexCoord0") :vec4) 27 | 28 | ;; fragment shader output 29 | (output color :vec4 :stage :fragment) 30 | 31 | ;; uniforms 32 | (uniform mv :mat4) ;; model-view matrix 33 | (uniform mvp :mat4) ;; model-view-projection matrix 34 | (uniform normal-matrix :mat4) 35 | (uniform time :float) 36 | 37 | 38 | ;; output from vertex shader, interpolated by GL then sent as input to 39 | ;; fragment shader 40 | ;; visible in vertex shader as 'outs', and in fragment shader as 'ins' 41 | (interface varyings (:out (:vertex outs) 42 | :in (:fragment ins)) 43 | (position :vec4) 44 | (normal :vec3) 45 | (color :vec4) 46 | (uv :vec4) 47 | (eye-direction :vec3) 48 | (light-direction :vec3)) 49 | 50 | ;; minimal shader program, just draw the object in solid red 51 | (defun minimal-vertex () 52 | ;; transform the input vertex position by the current 53 | ;; modelview-projection matrix and assign it to the built-in 54 | ;; GL-POSITION variable 55 | (setf gl-position (* mvp position))) 56 | 57 | (defun minimal-fragment () 58 | ;; set the output color to opaque red (R G B A = 1 0 0 1) 59 | (setf color (vec4 1 0 0 1))) 60 | 61 | 62 | 63 | ;; bit more complex, interpolate normals, and draw those to color 64 | (defun normal-vertex () 65 | (setf gl-position (* mvp position)) 66 | ;; transform normals and send to fragment shader 67 | (setf (@ outs normal) (* (mat3 normal-matrix) normal))) 68 | 69 | (defun normal-fragment () 70 | ;; just set the color to the interpolated normal, with alpha set to 1 71 | (setf color (vec4 (@ ins normal) 1))) 72 | 73 | ;; some constants for lighting (would probably be uniforms in a real program) 74 | (defconstant +ambient-color+ (vec3 0.0 0.024 0.06) :vec3) 75 | (defconstant +diffuse-color+ (vec3 0.6 0.4 0.2)#++(vec3 0.2 0.4 0.6) :vec3) 76 | (defconstant +specular-exponent+ 16 :float) 77 | (defconstant +light-position+ (vec3 4 4 -5) :vec3) 78 | 79 | ;; generic vertex shader used for a few lighting models 80 | (defun lighting-vertex () 81 | (setf gl-position (* mvp position)) 82 | (setf (@ outs normal) (* (mat3 normal-matrix) normal) 83 | (@ outs position) (* mv position) 84 | ;; interpolated lighting parameters 85 | (@ outs light-direction) (- +light-position+ (vec3 (* mv position))) 86 | (@ outs eye-direction) (- (vec3 (* mv position))))) 87 | 88 | (defun simple-lighting-fragment () 89 | ;; normalize the interpolated normal, since interpolation doesn't 90 | ;; preserve length 91 | (let* ((normal (normalize (@ ins normal))) 92 | ;; same for eye direction and light direction 93 | (eye-direction (normalize (@ ins eye-direction))) 94 | (light-direction (normalize (@ ins light-direction))) 95 | ;; calculate some intermediate values 96 | (l-dot-n (clamp (dot light-direction normal) 0 1)) 97 | (r (reflect (- light-direction) normal)) 98 | (r-dot-v (clamp (dot r eye-direction) 0 1)) 99 | (distance (length (@ ins eye-direction)))) 100 | (setf color (vec4 (+ +ambient-color+ 101 | (* (/ 2 distance) 102 | (+ (* +diffuse-color+ l-dot-n) 103 | (pow r-dot-v +specular-exponent+)))) 104 | 1)))) 105 | 106 | 107 | ;; add some random hacks to the lighting to make it look shinier 108 | ;; and factor out the lighting calculation so it can be reused 109 | (defun shiny-lighting (normal eye-dir light-dir distance) 110 | (let* ((l-dot-n (clamp (dot light-dir normal) 0 1)) 111 | (r (reflect (- light-dir) normal)) 112 | (r-dot-v (clamp (dot r eye-dir) 0 1)) 113 | ;; 0 when normal is perpendicular to view, used to fake 114 | ;; lambertian reflection 115 | (edge (dot eye-dir normal)) 116 | ;; factor out the specular calculation, and color the light a bit 117 | (spec (* (vec3 1 0.4 0.4) 118 | (pow r-dot-v +specular-exponent+)))) 119 | ;; make a sharp drop in specular highlight so it looks like 120 | ;; shinier reflection of a larger light instead of point 121 | (if (> (length spec) 0.8) 122 | (setf spec (* 0.8 (normalize spec))) 123 | (setf spec (* spec spec))) 124 | (return (vec4 (+ +ambient-color+ 125 | (* (/ 2 distance) 126 | (+ (* +diffuse-color+ 127 | l-dot-n) 128 | spec)) 129 | ;; fake lambert term 130 | ;; (everything is reflective as you approach 0 angle) 131 | (if (< edge 0.4) 132 | (* (clamp (- 1 (expt (/ edge 0.4) 2)) 0.0 1.0) 133 | (vec3 0.0 0.15 0.25)) 134 | (vec3 0))) 135 | 1)))) 136 | 137 | (defun shiny-fragment () 138 | (let* ((normal (normalize (@ ins normal))) 139 | (eye-direction (normalize (@ ins eye-direction))) 140 | (light-direction (normalize (@ ins light-direction))) 141 | (distance (length (@ ins eye-direction)))) 142 | (setf color 143 | (shiny-lighting normal eye-direction light-direction distance)))) 144 | 145 | ;; 4d perlin noise from "Efficient computational noise in GLSL" 146 | ;; https://github.com/ashima/webgl-noise/blob/master/src/noise4D.glsl 147 | ;; (original is MIT license) 148 | 149 | (defun mod289 (x) 150 | (return (- x (* 289 (floor (* x (/ 289))))))) 151 | 152 | (defun permute (x) 153 | (return (mod289 (* x (+ 1 (* x 34)))))) 154 | 155 | (defun grad4 (j ip) 156 | (let ((ones (ivec4 1 1 1 -1)) 157 | (p) 158 | (s)) 159 | (setf (.xyz p) (- (* (floor (* (fract (* (vec3 j) (.xyz ip))) 7)) 160 | (.z ip)) 161 | 1) 162 | (.w p) (- 1.5 (dot (abs (.xyz p)) (.xyz ones))) 163 | s (vec4 (less-than p (vec4 0))) 164 | (.xyz p) (+ (.xyz p) (* (1- (* (.xyz s) 2)) 165 | (.www s)))) 166 | (return p))) 167 | 168 | (defconstant +f4+ 0.309016994374947451 :float) 169 | 170 | (defun snoise (v) 171 | (let* ((c (vec4 0.138196601125011 ; (5 - sqrt(5))/20 G4 172 | 0.276393202250021 ; 2 * G4 173 | 0.414589803375032 ; 3 * G4 174 | -0.447213595499958)) ; -1 + 4 * G4 175 | ;; first corner 176 | (i (floor (+ v (dot v (vec4 +f4+))))) 177 | (x0 (+ (- v i) (dot i (.xxxx c)))) 178 | ;; other corners 179 | (i0) 180 | (is-x (step (.yzw x0) (.xxx x0))) 181 | (is-yz (step (.zww x0) (.yyz x0)))) 182 | (setf (.x i0) (+ (.x is-x) (.y is-x) (.z is-x)) 183 | (.yzw i0) (- 1 is-x)) 184 | (incf (.y i0) (+ (.x is-yz) (.y is-yz))) 185 | (incf (.zw i0) (- 1 (.xy is-yz))) 186 | (incf (.z i0) (.z is-yz)) 187 | (incf (.w i0) (- 1.0 (.z is-yz))) 188 | ;; i0 now contains the unique values 0,1,2,3 in each channel 189 | (let* ((i3 (clamp i0 0.0 1.0)) 190 | (i2 (clamp (- i0 1.0) 0.0 1.0)) 191 | (i1 (clamp (- i0 2.0) 0.0 1.0)) 192 | (x1 (+ (- x0 i1) (.xxxx C))) 193 | (x2 (+ (- x0 i2) (.yyyy C))) 194 | (x3 (+ (- x0 i3) (.zzzz C))) 195 | (x4 (+ x0 (.wwww C))) 196 | (i (mod289 i)) 197 | (j0 (permute (+ (permute (+ (permute (+ (permute (.w i)) 198 | (.z i))) 199 | (.y i))) 200 | (.x i)))) 201 | (j1 (macrolet ((p-i* (p z) 202 | `(permute (+ ,@(when p (list p)) 203 | (,z i) 204 | (vec4 (,z i1) (,z i2) 205 | (,z i3) 1.0))))) 206 | (p-i* (p-i* (p-i* (p-i* nil .w) .z) .y) .x))) 207 | (ip (vec4 (/ 294.0) (/ 49.0) (/ 7.0) 0.0)) 208 | (p0 (grad4 j0 ip)) 209 | (p1 (grad4 (.x j1) ip)) 210 | (p2 (grad4 (.y j1) ip)) 211 | (p3 (grad4 (.z j1) ip)) 212 | (p4 (grad4 (.w j1) ip)) 213 | (norm (inverse-sqrt (vec4 (dot p0 p0) 214 | (dot p1 p1) 215 | (dot p2 p2) 216 | (dot p3 p3))))) 217 | (setf p0 (* p0 (.x norm)) 218 | p1 (* p1 (.y norm)) 219 | p2 (* p2 (.z norm)) 220 | p3 (* p3 (.w norm)) 221 | p4 (* p4 (inverse-sqrt (dot p4 p4)))) 222 | (let* ((m0 (max (- 0.6 (vec3 (dot x0 x0) (dot x1 x1) (dot x2 x2))) 223 | 0.0)) 224 | (m1 (max (- 0.6 (vec2 (dot x3 x3) (dot x4 x4))) 225 | 0.0))) 226 | (setf m0 (* m0 m0) 227 | m1 (* m1 m1)) 228 | (return (* 49 (+ (dot (* m0 m0) (vec3 (dot p0 x0) 229 | (dot p1 x1) 230 | (dot p2 x2))) 231 | (dot (* m1 m1) (vec2 (dot p3 x3) 232 | (dot p4 x4)))))))))) 233 | 234 | ;; now make a fragment shader that uses perlin noise to distort the normals 235 | (defun noisy-shiny-fragment () 236 | (let* ((normal (@ ins normal)) 237 | (eye-direction (normalize (@ ins eye-direction))) 238 | (light-direction (normalize (@ ins light-direction))) 239 | (distance (length (@ ins eye-direction))) 240 | ;; calculate 3 octaves of noise based on fragment world 241 | ;; position and time 242 | (noise (+ (snoise (vec4 (* 2 (vec3 (@ ins position))) 243 | (/ time 5))) 244 | (* 0.5 245 | (snoise (vec4 (* 5.1 (vec3 (@ ins position))) 246 | (/ time 4)))) 247 | (* 0.2 248 | (snoise (vec4 (* 8.1 (vec3 (@ ins position))) 249 | (/ time 2)))))) 250 | ;; get derivatives of noise function 251 | ;; (probably should calculate directly and/or tweak glsl 252 | ;; sampling/interpolation settings, but works well enough 253 | ;; for an example) 254 | (dx (dfdx noise)) 255 | (dy (dfdy noise))) 256 | ;; push the normals a bit 257 | (incf (.x normal) (* 4 dx)) 258 | (incf (.y normal) (* 4 dy)) 259 | ;; and calculate lighting based on distorted normal 260 | (setf color (shiny-lighting (normalize normal) 261 | eye-direction light-direction distance)) 262 | (setf (.a color) 1))) 263 | -------------------------------------------------------------------------------- /example.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:3bgl-shader-example 2 | (:use #:cl) 3 | (:export 4 | #:run-example)) 5 | 6 | (in-package #:3bgl-shader-example-shaders) 7 | ;; combinations of shaders we will be using 8 | (cl:defparameter 3bgl-shader-example::*programs* 9 | '(() ;; skip an entry to use for fixed-function 10 | (minimal-vertex minimal-fragment) 11 | (normal-vertex normal-fragment) 12 | (lighting-vertex simple-lighting-fragment) 13 | (lighting-vertex shiny-fragment) 14 | (lighting-vertex noisy-shiny-fragment))) 15 | 16 | (in-package #:3bgl-shader-example) 17 | 18 | 19 | 20 | (defclass 3bgl-shader-example-window (glut:window) 21 | ((programs :accessor programs :initform nil) 22 | (index :accessor index :initform 0)) 23 | (:default-initargs :width 640 :height 480 :title "3bgl-shader" 24 | :mode '(:double :rgb :depth :multisample))) 25 | 26 | 27 | (defparameter *teapot-rotation-x* 0.0) 28 | (defparameter *teapot-rotation-y* 0.0) 29 | (defparameter *teapot-rotation-z* 0.0) 30 | 31 | (defun draw-teapot () 32 | (gl:clear-color 0 0.3 0.5 1.0) 33 | (gl:clear :color-buffer :depth-buffer) 34 | 35 | (gl:disable :blend :texture-2d) 36 | (gl:enable :lighting :light0 :depth-test) 37 | 38 | (gl:color-material :front :ambient-and-diffuse) 39 | 40 | (gl:light :light0 :position '(0 1 1 0)) 41 | (gl:light :light0 :diffuse '(0.2 0.4 0.6 0)) 42 | 43 | (gl:color 1 1 1) 44 | (glut:solid-teapot 1.3) 45 | 46 | (incf *teapot-rotation-x* 0.01) 47 | (incf *teapot-rotation-y* 0.05) 48 | (incf *teapot-rotation-z* 0.03)) 49 | 50 | 51 | 52 | 53 | (defparameter *modified-shader-functions* nil) 54 | 55 | (defun modified-shader-hook (modified) 56 | (format t "saw modified functions ~s~%" modified) 57 | (setf *modified-shader-functions* 58 | (union modified *modified-shader-functions*))) 59 | 60 | (pushnew 'modified-shader-hook 3bgl-shaders::*modified-function-hook*) 61 | 62 | (defun recompile-modified-shaders (w) 63 | (let* ((m *modified-shader-functions*) 64 | (current-program (nth (index w) (programs w)))) 65 | ;; flag any shaders we are using 66 | (loop for (p f names) in (programs w) 67 | do (loop for n in names 68 | for i from 0 69 | when (member n m) 70 | do (setf (nth i f) t))) 71 | ;; fixme: this needs a lock, since it could be modified from 72 | ;; another thread 73 | (setf *modified-shader-functions* nil) 74 | 75 | (destructuring-bind (&optional program flags names) 76 | current-program 77 | (when (and names 78 | (or (and program (some #'identity flags)) 79 | (and (not program) (every #'identity flags)))) 80 | (format t "~%recompiling shader program ~s for changes in functions:~& ~a~%" 81 | (index w) 82 | (loop for f in flags for n in names when f collect n)) 83 | (setf (second current-program) (substitute nil t flags)) 84 | (time 85 | (setf (car current-program) 86 | (3bgl-shaders::reload-program (first current-program) 87 | (first (third current-program)) 88 | (second (third current-program)) 89 | :geometry (third (third current-program)) 90 | :version 330))))))) 91 | 92 | 93 | (defparameter *w* nil) 94 | (defmethod glut:display ((w 3bgl-shader-example-window)) 95 | (with-simple-restart (continue "continue") 96 | (setf *w* w) 97 | (recompile-modified-shaders w) 98 | 99 | (gl:with-pushed-matrix* (:projection) 100 | (gl:load-identity) 101 | (glu:perspective 45 (/ (glut:width w) 102 | (glut:height w)) 103 | 0.5 20) 104 | (gl:with-pushed-matrix* (:modelview) 105 | (gl:load-identity) 106 | 107 | (flet ((radians (x) (coerce (/ (* pi x) 180) 'single-float)) 108 | (v (x y z) (sb-cga:vec (float x 1.0) 109 | (float y 1.0) 110 | (float z 1.0)))) 111 | (let* ((m (sb-cga:matrix* 112 | ;; some versions of glut transform the teapot 113 | ;; with gl matrix, so duplicate that here 114 | ;; (might not look right on newest freeglut though) 115 | (sb-cga:rotate-around (v 1 0 0) 116 | (radians 270)) 117 | (sb-cga:scale* (* 1.3 0.5) (* 1.3 0.5) (* 1.3 0.5)) 118 | (sb-cga:translate (v 0 0 -1.5)))) 119 | (v (sb-cga:matrix* 120 | (sb-cga:translate (v 0 0 -4)) 121 | (sb-cga:rotate-around (v 1 0 0) 122 | (radians *teapot-rotation-x*)) 123 | (sb-cga:rotate-around (v 0 1 0) 124 | (radians *teapot-rotation-y*)) 125 | (sb-cga:rotate-around (v 0 0 1) 126 | (radians *teapot-rotation-z*)))) 127 | (p (kit.math:perspective-matrix 45 128 | (/ (glut:width w) 129 | (glut:height w)) 130 | 0.5 20)) 131 | (mv (sb-cga:matrix* v m)) 132 | (mvp (sb-cga:matrix* p v m)) 133 | (p1 (car (nth (index w) (programs w))))) 134 | (gl:load-matrix v) 135 | (gl:matrix-mode :projection) 136 | (gl:load-matrix p) 137 | (gl:matrix-mode :modelview) 138 | (when p1 139 | (gl:use-program p1) 140 | (3bgl-shaders::uniformf p1 "time" 141 | (float 142 | (/ (get-internal-real-time) 143 | internal-time-units-per-second))) 144 | (3bgl-shaders::uniform-matrix p1 "mv" mv) 145 | (3bgl-shaders::uniform-matrix p1 "mvp" mvp) 146 | (3bgl-shaders::uniform-matrix p1 "normalMatrix" mv)))) 147 | 148 | (draw-teapot) 149 | (gl:use-program 0))) 150 | 151 | (glut:swap-buffers))) 152 | 153 | (defmethod glut:idle ((w 3bgl-shader-example-window)) 154 | (glut:post-redisplay)) 155 | 156 | (defmethod glut:reshape ((w 3bgl-shader-example-window) width height) 157 | (setf (glut:width w) width 158 | (glut:height w) height) 159 | (gl:viewport 0 0 (glut:width w) (glut:height w))) 160 | 161 | (defmethod glut:keyboard ((w 3bgl-shader-example-window) key x y) 162 | (declare (ignore x y)) 163 | (with-simple-restart 164 | (continue "continue") 165 | (case key 166 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) 167 | (let* ((n (digit-char-p key)) 168 | (names (nth n *programs*))) 169 | (setf (index w) n) 170 | (when names 171 | (unless (nth n (programs w)) 172 | (unless (> (length (programs w)) n) 173 | (setf (programs w) (replace (make-list (1+ n) 174 | :initial-element nil) 175 | (programs w)))) 176 | (setf (nth n (programs w)) 177 | ;; for each program we store program object, list of 178 | ;; modified flags, and list of shader functions 179 | ;; (vertex, fragment, optional geometry) 180 | (list nil 181 | (make-list (length names) :initial-element t) 182 | names)) 183 | (format t "added program ~s: ~s~%" n (programs w))) 184 | ) 185 | ) 186 | ) 187 | (#\Esc 188 | (glut:destroy-current-window))))) 189 | 190 | 191 | (defun run-example () 192 | (glut:display-window (make-instance '3bgl-shader-example-window))) 193 | -------------------------------------------------------------------------------- /finalize-inference.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | 3 | ;;; try to resolve a call graph to static types 4 | 5 | (defclass finalize (3bgl-glsl::glsl-walker) 6 | ()) 7 | 8 | 9 | ;; hash of function object -> equal-hash of (list of concrete types -> 10 | ;; (concrete return type + hash of bindings -> concrete types?)) 11 | (defvar *instantiated-overloads*) 12 | 13 | ;; hash of binding-object -> type, object removed at end of binding scope 14 | (defvar *binding-types*) 15 | 16 | (defun cache-binding (binding type) 17 | (when *verbose* 18 | (format t "~&setting type for binding ~s to ~s~%" 19 | (name binding) (name type))) 20 | (setf (gethash binding *binding-types*) type)) 21 | 22 | (defmethod flatten-type ((type concrete-type) &optional force-type) 23 | (etypecase force-type 24 | (null) 25 | (concrete-type 26 | force-type) 27 | (constrained-type 28 | (assert (= 1 (hash-table-count (types force-type)))) 29 | force-type))) 30 | 31 | (defmethod flatten-type ((type any-type) &optional force-type) 32 | (etypecase force-type 33 | (null 34 | ;; for now assuming an otherwise unconstrained type is 'void' 35 | ;; since otherwise something should have affected it 36 | ;; fixme: (not quite correct, since a few functions like = accept 37 | ;; any-type, so some rare functions could have unconstrained 38 | ;; types. also need to handle unused arguments) 39 | (get-type-binding :void)) 40 | (concrete-type 41 | #++(assert (eq type force-type)) 42 | #++(break "foo" force-type) 43 | (change-class type 'ref-type :equiv force-type) 44 | t) 45 | (constrained-type 46 | (flatten-type force-type)))) 47 | 48 | (defmethod flatten-type ((type constrained-type) &optional force-type) 49 | ;; pick simplest type (fewest components, then least casts to it 50 | ;; todo: figure out if any other types need rules? 51 | ;; usually should get single type for samplers or structs 52 | (let* ((out (mapcar 'car (remove nil (alexandria:hash-table-alist 53 | (types type)) 54 | :key 'cdr))) 55 | (old (length out))) 56 | (etypecase force-type 57 | ((or null constrained-type) 58 | (unless (= 1 old) 59 | (setf out (sort out (lambda (a b) 60 | (if (eql (scalar/vector-size a) 61 | (scalar/vector-size b)) 62 | (< (length (implicit-casts-from a)) 63 | (length (implicit-casts-from b))) 64 | (if (scalar/vector-size a) 65 | (and (scalar/vector-size b) 66 | (< (scalar/vector-size a) 67 | (scalar/vector-size b))) 68 | t))))) 69 | (clrhash (types type)) 70 | (when (typep force-type 'constrained-type) 71 | (setf out (remove-if-not (lambda (a) (gethash a (types force-type))) 72 | out)) 73 | (assert (plusp (length out)))) 74 | (setf (gethash (first out) (types type)) t) 75 | (flag-modified-type type) 76 | ;; return t since we modified it 77 | t)) 78 | (concrete-type 79 | (assert (gethash force-type (types type))) 80 | (when (> (hash-table-count (types type)) 1) 81 | (clrhash (types type)) 82 | (setf (gethash force-type (types type)) t) 83 | (flag-modified-type type) 84 | ;; return t since we modified it 85 | t))))) 86 | 87 | (defmethod flatten-type ((type array-type) &optional force-type) 88 | (declare (ignorable force-type)) 89 | #++(assert (not force-type)) ;; todo... 90 | (etypecase (base-type type) 91 | (concrete-type 92 | nil) 93 | ;; todo: figure out what other types need handled 94 | )) 95 | 96 | (defmethod flatten-type ((type struct-type) &optional force-type) 97 | (assert (or (not force-type) 98 | (eql type (get-equiv-type force-type)))) ;; todo... 99 | nil) 100 | 101 | (defmethod flatten-type ((type ref-type) &optional force-type) 102 | (flatten-type (equiv type) force-type)) 103 | 104 | (defmethod get-concrete-type ((type ref-type)) 105 | (get-concrete-type (equiv type))) 106 | 107 | (defmethod get-concrete-type ((type concrete-type)) 108 | type) 109 | 110 | (defmethod get-concrete-type ((type struct-type)) 111 | type) 112 | 113 | (defmethod get-concrete-type ((type array-type)) 114 | type) 115 | 116 | (defmethod get-concrete-type ((type any-type)) 117 | t) 118 | 119 | (defmethod get-concrete-type ((type constrained-type)) 120 | (let ((ct)) 121 | (maphash (lambda (k v) (when v (assert (not ct)) (setf ct k))) 122 | (types type)) 123 | ct)) 124 | 125 | (defun flatten-function (function argument-types) 126 | (setf argument-types (mapcar 'get-concrete-type argument-types)) 127 | (when *verbose* 128 | (format t "~%~%~%flattening function ~s: ~s~% ~s~%~%~%~%" (name function) 129 | (debug-type-names argument-types) 130 | argument-types)) 131 | (unless (gethash argument-types (final-binding-type-cache function)) 132 | ;; assume if we have a cached type, all called functions have been 133 | ;; cached as well. otherwise, figure out final types for this 134 | ;; combination of arguments, and process any called functions 135 | (let* ((local-types (make-hash-table)) 136 | (*current-function-local-types* local-types) 137 | (*copy-constraints-hash* (make-hash-table)) 138 | (*inference-worklist* nil)) 139 | ;; copy all the types used by the function 140 | (maphash (lambda (k v) 141 | (if (consp v) 142 | (setf (gethash k local-types) 143 | (mapcar #'copy-constraints v)) 144 | (setf (gethash k local-types) 145 | (copy-constraints v)))) 146 | (local-binding-type-data function)) 147 | ;; fixme: copy-constraints adds things to worklist too agressively 148 | ;; so go through and undo it... 149 | ;;(run-type-inference) 150 | (loop for i = (pop *inference-worklist*) 151 | while i 152 | do (setf (modified i) nil)) 153 | 154 | ;; assign types to function arguments, run type inference if 155 | ;; any changed 156 | (assert (= (length argument-types) (length (bindings function)))) 157 | (when (plusp (loop for arg in argument-types 158 | for binding in (bindings function) 159 | count (flatten-type (gethash binding local-types) 160 | arg))) 161 | ;; updated arguments 162 | (run-type-inference)) 163 | 164 | ;; loop through variable bindings 165 | ;; if multiple types, collapse to simplest type then run 166 | ;; type inference 167 | 168 | ;; loop over keys instead of maphash because inference update 169 | ;; might modify other parts of hash table 170 | (loop for k in (alexandria:hash-table-keys local-types) 171 | for .v = (gethash k local-types) 172 | for v = (get-equiv-type .v) 173 | do (unless (eq v .v) 174 | (setf (gethash k local-types) v)) 175 | (if (typep k '(or local-variable)) 176 | (progn 177 | (when *verbose* 178 | (format t "update local variable ~s (~s)~%" (name k) 179 | (debug-type-names v))) 180 | (when (flatten-type v) 181 | (run-type-inference))))) 182 | 183 | ;; flatten called function arguments 184 | ;; (mostly needed for spirv, since it doesn't have implicit casts) 185 | (loop for k in (alexandria:hash-table-keys local-types) 186 | for .v = (gethash k local-types) 187 | for v = (get-equiv-type .v) 188 | do (unless (eq v .v) 189 | (setf (gethash k local-types) v)) 190 | (when (typep k '(or function-call)) 191 | (when *verbose* 192 | (format t "update function-call arguments ~s (~s)~%" 193 | (name (called-function k)) 194 | (debug-type-names v))) 195 | (when (plusp (loop for arg in v 196 | when arg 197 | count (flatten-type arg))) 198 | (run-type-inference)))) 199 | 200 | ;; flatten return type of function 201 | (flatten-type (gethash :return local-types)) 202 | (when (typep (gethash :return local-types) 'any-type) 203 | (setf (gethash :return local-types) 204 | (get-type-binding :void))) 205 | ;; build mapping of variables/functions to types for this 206 | ;; combination of arguments 207 | (let ((cache (make-hash-table))) 208 | (maphash (lambda (k v) 209 | (if (typep k '(or function-call inference-call-site)) 210 | (progn 211 | (when *verbose* 212 | (format t "use function ~s: ~s~%" 213 | (name (called-function k)) 214 | (debug-type-names v))) 215 | (assert (not (gethash k cache nil))) 216 | (setf (gethash k cache nil) 217 | (mapcar (lambda (a) 218 | (when a 219 | (flatten-type a) 220 | (get-concrete-type a))) 221 | v)) 222 | (when *verbose* 223 | (format t "-> ~s~%" 224 | (debug-type-names (gethash k cache :?))))) 225 | (setf (gethash k cache) v))) 226 | local-types) 227 | (setf (gethash argument-types (final-binding-type-cache function)) 228 | cache)))) 229 | (when *verbose* 230 | (format t "~%~% flattened ~s: ~s -> ~s~%~s~%" 231 | (name function) (debug-type-names argument-types) 232 | (debug-type-names 233 | (gethash :return (gethash argument-types 234 | (final-binding-type-cache function)))) 235 | argument-types)) 236 | 237 | ;; add any used function signatures to the hash table for printing 238 | (maphash (lambda (k v) 239 | (when (and (typep k 'inference-call-site) 240 | (typep (called-function k) 'global-function)) 241 | (flatten-function (called-function k) (cdr v)))) 242 | (gethash argument-types (final-binding-type-cache function))) 243 | (unless (gethash function *instantiated-overloads*) 244 | (setf (gethash function *instantiated-overloads*) 245 | (make-hash-table :test #'equal))) 246 | (setf (gethash argument-types (gethash function *instantiated-overloads*)) 247 | t) 248 | (gethash :return 249 | (gethash argument-types (final-binding-type-cache function)))) 250 | 251 | 252 | ;;; given a 0-arg function, return a hash table of 253 | ;;; function names -> list of overloads to instantiate for that function 254 | ;;; hash of binding -> type for that function and all bindings in it 255 | 256 | (defun finalize-inference (root) 257 | (let ((*instantiated-overloads* (make-hash-table)) 258 | (*binding-types* (make-hash-table))) 259 | 260 | (flatten-function root nil) 261 | 262 | ;; reformat the data for printer to use 263 | (maphash (lambda (k v) 264 | (setf (gethash k *instantiated-overloads*) 265 | (alexandria:hash-table-keys v))) 266 | *instantiated-overloads*) 267 | *instantiated-overloads*)) 268 | -------------------------------------------------------------------------------- /glsl-base.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-glsl) 2 | 3 | ;;; definitions for CL macros supported by the shader DSL 4 | ;;; (and maybe some extra utilities) 5 | 6 | 7 | (defclass glsl-walker (3bgl-shaders::cl-walker) 8 | ()) 9 | 10 | (defparameter *current-function* nil 11 | "current function being compiled if any") 12 | 13 | 14 | #++ 15 | (let ((a nil)) 16 | (do-external-symbols (s (find-package :cl) 17 | (sort a 'string<)) 18 | (when (and (fboundp s) (not (special-operator-p s)) 19 | (macro-function s)) 20 | (push s a)))) 21 | 22 | ;;; stuff that is (or at least could be) handled by compiler: 23 | ;;; all args are (potentially) evaluated normally, etc 24 | ;;; AND, DECF, INCF, OR, 25 | 26 | ;;; not implementing (either not meaningful/useful or too hard) 27 | ;;; (clos, runtime exceptions, etc) 28 | (loop for s in 29 | '(CALL-METHOD ASSERT CCASE CTYPECASE DEFCLASS DEFGENERIC 30 | DEFINE-CONDITION DEFINE-METHOD-COMBINATION DEFMETHOD 31 | DEFPACKAGE DESTRUCTURING-BIND DO-ALL-SYMBOLS 32 | DO-EXTERNAL-SYMBOLS DO-SYMBOLS ECASE ETYPECASE FORMATTER 33 | HANDLER-BIND HANDLER-CASE IGNORE-ERRORS IN-PACKAGE 34 | MULTIPLE-VALUE-BIND MULTIPLE-VALUE-LIST MULTIPLE-VALUE-SETQ 35 | NTH-VALUE PPRINT-EXIT-IF-LIST-EXHAUSTED PPRINT-LOGICAL-BLOCK 36 | PPRINT-POP PRINT-UNREADABLE-OBJECT PROG PROG* PUSHNEW 37 | RESTART-BIND RESTART-CASE TIME TRACE UNTRACE 38 | WITH-CONDITION-RESTARTS WITH-HASH-TABLE-ITERATOR 39 | WITH-COMPILATION-UNIT WITH-INPUT-FROM-STRING WITH-OPEN-FILE 40 | WITH-OPEN-STREAM WITH-OUTPUT-TO-STRING WITH-PACKAGE-ITERATOR 41 | WITH-SIMPLE-RESTART WITH-STANDARD-IO-SYNTAX) 42 | do (3bgl-shaders::add-macro 43 | s 44 | `(lambda (&rest r) 45 | (declare (ignore r)) 46 | (error ,(format nil "~a not supported in GLSL" s))) 47 | :env *glsl-base-environment*)) 48 | 49 | ;;; not sure if we will have some 'list' equivalent? 50 | (loop for s in 51 | '(POP DOLIST PUSH REMF) 52 | do (3bgl-shaders::add-macro 53 | s 54 | `(lambda (&rest r) 55 | (declare (ignore r)) 56 | (error ,(format nil "~a not supported in GLSL" s))) 57 | :env *glsl-base-environment*)) 58 | 59 | 60 | ;;; maybe? 61 | (loop for s in 62 | '(DECLAIM CHECK-TYPE DEFTYPE DEFINE-SETF-EXPANDER DEFSETF LAMBDA TYPECASE 63 | WITH-ACCESSORS WITH-SLOTS) 64 | do (3bgl-shaders::add-macro 65 | s 66 | `(lambda (&rest r) 67 | (declare (ignore r)) 68 | (error ,(format nil "~a not supported in GLSL (yet?)" s))) 69 | :env *glsl-base-environment*)) 70 | 71 | ;;; todo: 72 | 73 | (%glsl-macro case (form &body body) 74 | (flet ((numeric-constant (s) 75 | (typecase s 76 | (number s) 77 | ;; accepting constants even though CL CASE doesn't, since 78 | ;; that is annoying 79 | (symbol 80 | (let ((v (3bgl-shaders::get-variable-binding s))) 81 | (and v 82 | ;; todo: factor this stuff out 83 | (typep v '3bgl-shaders::constant-binding) 84 | (typep (3bgl-shaders::value-type v) 85 | '3bgl-shaders::concrete-type) 86 | (member (3bgl-shaders::name 87 | (3bgl-shaders::value-type v)) 88 | ;; glsl `switch` takes integers, so 89 | ;; limiting to that even though we 90 | ;; currently expand to nested IF which 91 | ;; could take floats too 92 | '(:int :int8 :int16 :int32 :int64 93 | :uint :uint8 :uint16 :uint32 :uint64))))) 94 | (t s)))) 95 | (loop for (case) in body 96 | do (assert (or (numeric-constant case) 97 | (eql case t) 98 | (and (consp case) (every #'numeric-constant case))))) 99 | (labels ((c (x) 100 | (etypecase x 101 | (cons `(or ,@(loop for v in x collect `(= ,form ,v)))) 102 | (number `(= ,form ,x)) 103 | (symbol 104 | (assert (numeric-constant x)) 105 | `(= ,form ,x)))) 106 | (r (b) 107 | (let ((a (first b))) 108 | (if (eql (first a) t) 109 | `(progn ,@(rest a)) 110 | `(if ,(c (first a)) 111 | (progn ,@(rest a)) 112 | ,@ (when (rest b) 113 | (list (r (rest b))))))))) 114 | (r body)))) 115 | 116 | 117 | (%glsl-macro cond (&body body) 118 | (if (eq (caar body) t) 119 | `(progn ,@(cdar body)) 120 | `(if ,(caar body) 121 | (progn ,@(cdar body)) 122 | ,@(when (cdr body) 123 | `((cond ,@(cdr body))))))) 124 | 125 | 126 | (%glsl-macro define-compiler-macro (name lambda-list &body body) 127 | ;; fixme: extract docstrings/declarations from body 128 | (3bgl-shaders::add-compiler-macro name 129 | `(lambda (form env) 130 | (declare (ignore env)) 131 | (destructuring-bind ,lambda-list 132 | (cdr form) 133 | ,@body))) 134 | nil) 135 | 136 | 137 | (%glsl-macro define-modify-macro (&body body) 138 | (declare (ignore body)) 139 | `(error "DEFINE-MODIFY-MACRO not implemented yet for GLSL")) 140 | 141 | (%glsl-macro define-symbol-macro (name expansion) 142 | (3bgl-shaders::add-symbol-macro name expansion) 143 | nil) 144 | 145 | (%glsl-macro cl:defmacro (name lambda-list &body body) 146 | ;; fixme: extract docstrings/declarations from body 147 | #++(format t "define macro ~s~%" name) 148 | (3bgl-shaders::add-macro name 149 | `(lambda (form env) 150 | (declare (ignore env)) 151 | (destructuring-bind ,lambda-list 152 | (cdr form) 153 | ,@body))) 154 | nil) 155 | 156 | 157 | ;;; no 'unbound' variables in GLSL, so requiring value arg, and 158 | ;;; not sure there is any distinction between DEFVAR and DEFPARAMETER 159 | ;;; in shaders, so just expanding to defparameter... 160 | (%glsl-macro defvar (name value &optional docs) 161 | (declare (ignore docs)) 162 | `(defparameter ,name ,value)) 163 | 164 | (%glsl-macro do (&body body) 165 | (declare (ignore body)) 166 | `(error "DO not implemented yet for GLSL")) 167 | 168 | (%glsl-macro do* (&body body) 169 | (declare (ignore body)) 170 | `(error "DO* not implemented yet for GLSL")) 171 | 172 | (%glsl-macro dotimes ((var count &optional (result nil)) &body body) 173 | (if result 174 | `(error "RESULT not implemented for GLSL DOTIMES yet") 175 | `(let ((,var 0)) 176 | (declare (:int ,var)) 177 | (%for (nil ((< ,var ,count)) ((incf ,var))) 178 | ,@body)))) 179 | 180 | (%glsl-macro loop (&body body) 181 | (declare (ignore body)) 182 | `(error "LOOP not implemented yet for GLSL")) 183 | 184 | (%glsl-macro loop-finish (&body body) 185 | (declare (ignore body)) 186 | `(error "LOOP-FINISH not implemented yet for GLSL")) 187 | 188 | (%glsl-macro prog1 (first-form &body form*) 189 | (alexandria:with-gensyms (temp) 190 | `(let ((,temp ,first-form)) 191 | ,@form* 192 | ,temp))) 193 | 194 | (%glsl-macro prog2 (first-form second-form &rest form*) 195 | (alexandria:with-gensyms (temp) 196 | `(progn 197 | ,first-form 198 | (let ((,temp ,second-form)) 199 | ,@form* 200 | ,temp)))) 201 | 202 | (%glsl-macro PSETF (&body body) 203 | (error "PSETF not implemented yet for GLSL") 204 | `(,@body)) 205 | 206 | (%glsl-macro PSETQ (&body body) 207 | (error "PSETQ not implemented yet for GLSL") 208 | `(,@body)) 209 | 210 | ;; handle by compiler for now? 211 | #++ 212 | (%glsl-macro return (&body body) 213 | `(,@body)) 214 | 215 | (%glsl-macro rotatef (&body args) 216 | (when (cdr args) ;; ignore it if 1 or fewer places 217 | (alexandria:with-gensyms (temp) 218 | `(let ((,temp ,(car args))) 219 | ,@(loop for (a . b) on args 220 | while b 221 | collect `(setf ,a ,(car b))) 222 | (setf ,(car (last args)) ,temp) 223 | ;; rotatef returns NIL 224 | nil)))) 225 | 226 | (%glsl-macro setf (&body pairs) 227 | ;; for now, just expand to a bunch of SETQ forms and hope the 228 | ;; compiler can deal with them 229 | ;; (probably implementing things like swizzles and maybe struct 230 | ;; accesse at that level, so should be enough for a while, but 231 | ;; will probably eventually want to be able to do stuff like 232 | ;; (setf (ldb...) foo) etc.) 233 | (if (> (length pairs) 2) 234 | `(progn ,@(loop for (a b) on pairs by #'cddr 235 | collect `(setq ,a ,b))) 236 | `(setq ,(first pairs) ,(second pairs)))) 237 | 238 | (%glsl-macro shiftf (&rest args) 239 | (alexandria:with-gensyms (temp) 240 | `(let ((,temp ,(car args))) 241 | ,@(loop for (a . b) on args 242 | while b 243 | collect `(setf ,a ,(car b))) 244 | ,temp))) 245 | 246 | 247 | (%glsl-macro incf (x &optional (inc 1)) 248 | `(setf ,x (+ ,x ,inc))) 249 | 250 | (%glsl-macro unless (a &rest b) 251 | ;; not quite usual expansion, since we don't really have a "NIL" to return 252 | `(if (not ,a) (progn ,@b))) 253 | 254 | (%glsl-macro when (a &rest b) 255 | `(if ,a (progn ,@b))) 256 | 257 | ;;; translate into IR 258 | 259 | (cl:defun filter-progn (x) 260 | (loop for i in x 261 | ;; if we have a progn in the body, just expand the contents 262 | ;; (but not something with progn as a mixin) 263 | when (eq (class-of i) (find-class '3bgl-shaders::progn-body)) 264 | append (filter-progn (3bgl-shaders::body i)) 265 | else 266 | if i 267 | collect i)) 268 | 269 | (3bgl-shaders::defwalker glsl-walker (defparameter name value &optional docs) 270 | (declare (ignore docs)) 271 | (3bgl-shaders::add-variable name (3bgl-shaders::@ value) 272 | :type '3bgl-shaders::global-variable)) 273 | 274 | (3bgl-shaders::defwalker glsl-walker (cl:defconstant name value &optional docs) 275 | (declare (ignore docs)) 276 | (3bgl-shaders::add-variable name 277 | (3bgl-shaders::@ value) 278 | :type '3bgl-shaders::constant-binding)) 279 | 280 | (3bgl-shaders::defwalker glsl-walker (%defconstant name value type) 281 | (3bgl-shaders::add-variable name 282 | (3bgl-shaders::@ value) 283 | :type '3bgl-shaders::constant-binding 284 | :value-type type)) 285 | 286 | #++ 287 | (3bgl-shaders::defwalker glsl-walker (cl:defun name lambda-list &body body+d) 288 | (3bgl-shaders::process-type-declarations-for-scope 289 | (multiple-value-bind (body declare doc) 290 | (alexandria:parse-body body+d :documentation t) 291 | (3bgl-shaders::add-function name lambda-list 292 | (filter-progn (3bgl-shaders::@@ body)) 293 | :declarations declare :docs doc)))) 294 | 295 | (3bgl-shaders::defwalker glsl-walker (let (&rest bindings) &rest body+d) 296 | (let ((previous (make-hash-table))) 297 | (3bgl-shaders::process-type-declarations-for-scope 298 | (multiple-value-bind (body declare) 299 | (alexandria:parse-body body+d) 300 | (let ((l (make-instance 301 | '3bgl-shaders::binding-scope 302 | :bindings (loop for (n i) in bindings 303 | do (setf (gethash n previous) t) 304 | collect (make-instance 305 | '3bgl-shaders::local-variable 306 | :name n 307 | :init (let ((3bgl-shaders::*check-conflict-vars* previous)) 308 | (3bgl-shaders::@ i)) 309 | :value-type t)) 310 | :declarations declare 311 | :body nil))) 312 | (loop for (n i) in bindings 313 | for b in (3bgl-shaders::bindings l) 314 | when (eq (gethash n previous) :conflict) 315 | do (setf (3bgl-shaders::conflicts b) t)) 316 | (setf (3bgl-shaders::body l) 317 | (3bgl-shaders::with-lambda-list-vars (l) 318 | (3bgl-shaders::@@ body))) 319 | l))))) 320 | 321 | (3bgl-shaders::defwalker glsl-walker (let* (&rest bindings) &rest body+d) 322 | (multiple-value-bind (body declare) 323 | (alexandria:parse-body body+d) 324 | (3bgl-shaders::process-type-declarations-for-scope 325 | (3bgl-shaders::with-environment-scope () 326 | (make-instance 327 | '3bgl-shaders::binding-scope 328 | :bindings (loop for (n i) in bindings 329 | for b = (make-instance 330 | '3bgl-shaders::local-variable 331 | :name n 332 | :init (3bgl-shaders::@ i) 333 | :value-type t) 334 | collect b 335 | do (3bgl-shaders::add-variable n i :binding b)) 336 | :declarations declare 337 | :body (3bgl-shaders::@@ body)))))) 338 | 339 | (3bgl-shaders::defwalker glsl-walker (progn &body body) 340 | (make-instance '3bgl-shaders::explicit-progn 341 | :body (filter-progn (3bgl-shaders::@@ body)))) 342 | 343 | (3bgl-shaders::defwalker glsl-walker (setq &rest assignments) 344 | (cond 345 | ;; if we have multiple assignments, expand to a sequence of 2 arg setq 346 | ((> (length assignments) 2) 347 | (3bgl-shaders::walk `(progn ,@(loop for (a b) on assignments by #'cddr 348 | collect `(setq a b))) 349 | 3bgl-shaders::walker)) 350 | ;; single assignment 351 | ((= (length assignments) 2) 352 | (let* ((binding (3bgl-shaders::@ (first assignments))) 353 | (value (second assignments))) 354 | (assert (typep binding '3bgl-shaders::place)) 355 | (make-instance '3bgl-shaders::variable-write 356 | :binding binding 357 | :value (3bgl-shaders::@ value)))) 358 | (t (error "not enough arguments for SETQ in ~s?" assignments)))) 359 | 360 | (3bgl-shaders::defwalker glsl-walker (if a b &optional c) 361 | (make-instance '3bgl-shaders::if-form 362 | :test (3bgl-shaders::@ a) 363 | :then (3bgl-shaders::@ b) 364 | :else (3bgl-shaders::@ c))) 365 | 366 | (3bgl-shaders::defwalker glsl-walker (%for (init while step) &body body) 367 | (make-instance '3bgl-shaders::for-loop 368 | :init (mapcar #'3bgl-shaders::@ init) 369 | :while (mapcar #'3bgl-shaders::@ while) 370 | :step (mapcar #'3bgl-shaders::@ step) 371 | :body (3bgl-shaders::@@ body))) 372 | 373 | 374 | ;; function application 375 | (defmethod 3bgl-shaders::walk-cons (car cdr (walker glsl-walker)) 376 | ;; should have already expanded macros/local functions by now, 377 | ;; so anything left is a function call of some sort 378 | ;; we also handle a few special cases here for now: 379 | ;; symbols starting with #\. are treated as struct slot accessors/swizzle 380 | ;; aref forms are converted specially 381 | (let ((binding (3bgl-shaders::get-function-binding car)) 382 | (macro (3bgl-shaders::get-macro-function car)) 383 | (cmacro (3bgl-shaders::get-compiler-macro-function car))) 384 | (flet ((add-dependencies (called) 385 | called)) 386 | (cond 387 | ((and cmacro 388 | (let* ((form (list* car cdr)) 389 | (expanded (funcall cmacro form 390 | 3bgl-shaders::*environment*))) 391 | (if (eq expanded form) 392 | nil 393 | (3bgl-shaders::walk expanded walker))))) 394 | (macro 395 | (3bgl-shaders::walk (funcall macro (list* car cdr) 396 | 3bgl-shaders::*environment*) 397 | walker)) 398 | ((typep binding '3bgl-shaders::function-binding-function) 399 | (add-dependencies binding) 400 | (make-instance '3bgl-shaders::function-call 401 | :function binding 402 | :raw-arguments cdr 403 | :argument-environment 3bgl-shaders::*environment* 404 | :arguments (mapcar (lambda (x) 405 | (3bgl-shaders::walk x walker)) 406 | (funcall (3bgl-shaders::expander binding) 407 | cdr)))) 408 | ((eq car 'aref) 409 | (make-instance '3bgl-shaders::array-access 410 | :binding (3bgl-shaders::walk (first cdr) walker) 411 | :index (3bgl-shaders::walk (second cdr) walker))) 412 | ((eq car 'vector) 413 | ;; todo: fix type inference/dependency tracking so we can get 414 | ;; rid of this 415 | (unless (every 'atom cdr) 416 | (error "can't handle function calls in array initialization yet")) 417 | (make-instance '3bgl-shaders::array-initialization 418 | :raw-arguments cdr 419 | :argument-environment 3bgl-shaders::*environment* 420 | :arguments (mapcar (lambda (x) 421 | (3bgl-shaders::walk x walker)) 422 | cdr) 423 | :base-type t 424 | :array-size (length cdr) 425 | :name (if (< (length cdr) 16) 426 | (cons car cdr) 427 | 'vector))) 428 | ;; not sure about syntax for slot/swizzle, for now 429 | ;; using (@ struct slot) or (slot-value struct 'slot) for slot access 430 | ;; and (.xyz vec) for swizzle 431 | ((or (eq car '@) 432 | (and (eq car 'slot-value) 433 | (eq (caadr cdr) 'quote))) 434 | (make-instance '3bgl-shaders::slot-access 435 | :binding (3bgl-shaders::walk (first cdr) walker) 436 | :field (if (consp (second cdr)) 437 | (second (second cdr)) 438 | (second cdr)))) 439 | ((and (symbolp car) 440 | (char= (char (symbol-name car) 0) #\.) 441 | ;; fixme: do this more efficiently 442 | ;; swizzle should look like .AAAA where AAAA is up to 4 443 | ;; characters from either XYZW, RGBA, or STPQ 444 | ;; (repeats allowed) 445 | (= 1 (count #\. (symbol-name car) :test #'char=)) 446 | (<= 2 (length (symbol-name car)) 5) 447 | (or (every (lambda (a) (position a ".XYZW" :test #'char=)) 448 | (symbol-name car)) 449 | (every (lambda (a) (position a ".RGBA" :test #'char=)) 450 | (symbol-name car)) 451 | (every (lambda (a) (position a ".STPQ" :test #'char=)) 452 | (symbol-name car)))) 453 | (make-instance '3bgl-shaders::swizzle-access 454 | :binding (3bgl-shaders::walk (first cdr) walker) 455 | :field (subseq (string car) 1) 456 | :min-size (loop for i from 1 below (length (string car)) 457 | for c = (aref (string car) i) 458 | maximize (or (position c "RGBA") 459 | (position c "XYZW") 460 | (position c "STPQ"))))) 461 | ((symbolp car) 462 | (make-instance '3bgl-shaders::function-call 463 | :function (add-dependencies 464 | (3bgl-shaders::add-unknown-function car)) 465 | :raw-arguments cdr 466 | :argument-environment 3bgl-shaders::*environment* 467 | :arguments nil)) 468 | (t 469 | (call-next-method)))))) 470 | 471 | ;; literals and variable access 472 | (defmethod 3bgl-shaders::walk (form (walker glsl-walker)) 473 | ;; symbol macros should already be expanded, so nothing left but 474 | ;; literals, variables and constants 475 | ;; (would be nice to expand constants inline, but we might not 476 | ;; know the actual value yet, and the form used to initialize the constant 477 | ;; might be expensive to evaluate repeatedly) 478 | (when form 479 | (let ((binding (if (symbolp form) 480 | (3bgl-shaders::get-variable-binding form) 481 | form))) 482 | (typecase binding 483 | (3bgl-shaders::symbol-macro 484 | (3bgl-shaders::walk (3bgl-shaders::expansion binding) walker)) 485 | (3bgl-shaders::binding 486 | (make-instance '3bgl-shaders::variable-read 487 | :binding binding)) 488 | (number 489 | form) 490 | (vector 491 | form) 492 | ((or 3bgl-shaders::variable-read 3bgl-shaders::variable-write 493 | 3bgl-shaders::binding-scope 494 | 3bgl-shaders::slot-access 3bgl-shaders::swizzle-access 495 | 3bgl-shaders::array-access 496 | 3bgl-shaders::function-call 3bgl-shaders::global-function 497 | 3bgl-shaders::explicit-progn 3bgl-shaders::for-loop 498 | 3bgl-shaders::interface-type 3bgl-shaders::concrete-type 499 | 3bgl-shaders::array-initialization 500 | 3bgl-shaders::interface-stage-binding 501 | 3bgl-shaders::struct-type) 502 | form) 503 | (t (break "unknown binding ~s / ~s (~s)" form binding 3bgl-shaders::*environment*)))))) 504 | 505 | 506 | 507 | #++ 508 | (let ((3bgl-shaders::*environment* 509 | (make-instance '3bgl-shaders::environment 510 | :parent *glsl-base-environment*))) 511 | (3bgl-shaders::walk '(progn 512 | (defmacro do-stuff (a) 513 | `(doing-stuff ,a)) 514 | (cond 515 | ((= foo 1) 516 | (do-stuff foo) 517 | (more foo = 1)) 518 | ((= bar 2)) 519 | (t (default stuff)))) 520 | (make-instance '3bgl-shaders::cl-walker))) 521 | 522 | 523 | 524 | ;;; start defining some glsl functions 525 | (%glsl-macro expt (a b) 526 | `(pow ,a ,b)) 527 | 528 | 529 | 530 | (cl:defun call-with-package-environment (thunk &key (package *package*)) 531 | (let ((3bgl-shaders::*environment* (ensure-package-environment package)) 532 | (3bgl-shaders::*global-environment* (ensure-package-environment package))) 533 | (funcall thunk))) 534 | 535 | (cl:defmacro with-package-environment ((&optional symbol) &body body) 536 | `(call-with-package-environment (lambda () ,@body) 537 | :package ,(if symbol 538 | `(symbol-package ,symbol) 539 | '*package*))) 540 | 541 | ;;; api for defining GLSL code from CL code 542 | ;; (as opposed to compiling a block of GLSL code as GLSL code, which can 543 | ;; just use DEFUN etc directly) 544 | 545 | (cl:defmacro glsl-defun (name args &body body) 546 | `(with-package-environment () 547 | (3bgl-shaders::walk '(cl:defun ,name ,args ,@body) 548 | (make-instance '3bgl-shaders::extract-functions)))) 549 | 550 | (cl:defmacro glsl-defconstant (name value type) 551 | `(with-package-environment () 552 | (3bgl-shaders::walk '(%defconstant ,name ,value ,type) 553 | (make-instance '3bgl-shaders::extract-functions)))) 554 | 555 | (cl:defmacro glsl-interface (name (&rest args &key in out uniform) &body slots) 556 | (declare (ignore in out uniform)) 557 | `(with-package-environment () 558 | (3bgl-shaders::walk '(interface ,name ,args ,@slots) 559 | (make-instance '3bgl-shaders::extract-functions)))) 560 | 561 | (cl:defmacro glsl-attribute (name type &rest args &key location) 562 | (declare (ignore location)) 563 | `(with-package-environment () 564 | (3bgl-shaders::walk '(attribute ,name ,type ,@args) 565 | (make-instance '3bgl-shaders::extract-functions)))) 566 | 567 | (cl:defmacro glsl-input (name type &rest args &key stage location) 568 | (declare (ignore location stage)) 569 | `(with-package-environment () 570 | (3bgl-shaders::walk '(input ,name ,type ,@args) 571 | (make-instance '3bgl-shaders::extract-functions)))) 572 | 573 | (cl:defmacro glsl-output (name type &rest args &key stage location) 574 | (declare (ignore location stage)) 575 | `(with-package-environment () 576 | (3bgl-shaders::walk '(output ,name ,type ,@args) 577 | (make-instance '3bgl-shaders::extract-functions)))) 578 | 579 | (cl:defmacro glsl-uniform (name type &rest args &key stage location) 580 | (declare (ignore location stage)) 581 | `(with-package-environment () 582 | (3bgl-shaders::walk '(uniform ,name ,type ,@args) 583 | (make-instance '3bgl-shaders::extract-functions)))) 584 | 585 | (cl:defmacro glsl-bind-interface (stage block-name interface-qualifier instance-name) 586 | `(with-package-environment () 587 | (3bgl-shaders::walk '(bind-interface ,stage ,block-name 588 | ,interface-qualifier ,instance-name) 589 | (make-instance '3bgl-shaders::extract-functions)))) 590 | -------------------------------------------------------------------------------- /glsl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-glsl) 2 | 3 | ;; define builtin types, probably should move builtin functions here 4 | ;; from glsl-base, and add separate package for each version... 5 | 6 | (let ((3bgl-shaders::*environment* *glsl-base-environment*) 7 | (3bgl-shaders::*global-environment* *glsl-base-environment*) 8 | (walker (make-instance 'glsl-walker))) 9 | (macrolet ((input (name type stage &rest qualifiers) 10 | (declare (ignorable qualifiers)) 11 | `(3bgl-shaders::walk '(input ,name ,type :stage ,stage 12 | :internal t) 13 | walker)) 14 | ;; alias for INPUT for now 15 | (const (name type stage &rest qualifiers) 16 | (declare (ignorable qualifiers)) 17 | `(3bgl-shaders::walk '(input ,name ,type :stage ,stage 18 | :internal t) 19 | walker)) 20 | (output (name type stage &rest qualifiers) 21 | (declare (ignorable qualifiers)) 22 | `(3bgl-shaders::walk '(output ,name ,type :stage ,stage 23 | :internal t) 24 | walker)) 25 | (interface (name (&rest bind) &body slots) 26 | `(3bgl-shaders::walk '(interface ,name (,@bind :internal t) 27 | ,@slots) 28 | walker))) 29 | 30 | ;; compute (430+) 31 | (input (gl-num-work-groups "gl_NumWorkGroups") :uvec3 :compute) 32 | (const (gl-work-group-size "gl_WorkGroupSize") :uvec3 :compute) 33 | (input (gl-work-group-id "gl_WorkGroupID") :uvec3 :compute) 34 | (input (gl-local-invocation-id "gl_LocalInvocationID") :uvec3 :compute) 35 | (input (gl-global-invocation-id "gl_GlobalInvocationID") :uvec3 :compute) 36 | (input (gl-local-invocation-index "gl_LocalInvocationIndex") :int :compute) 37 | 38 | 39 | ;; vertex 40 | (input (gl-vertex-id "gl_VertexID") :int :vertex) 41 | (input (gl-instance-id "gl_InstanceID") :int :vertex) 42 | (input (gl-draw-id "gl_DrawID") :int :vertex) 43 | (input (gl-base-vertex "gl_BaseVertex") :int :vertex) 44 | (input (gl-base-instance "gl_BaseInstance") :int :vertex) 45 | (interface (gl-per-vertex "gl_PerVertex") 46 | (:out (:vertex t 47 | :geometry t 48 | ;; fixme: should be gl_out[] 49 | :tess-control gl-out 50 | :tess-eval t) 51 | ;; fixme: should be gl_in[] 52 | :in (:geometry (gl-in "gl_in") 53 | :tess-control (gl-in "gl_in") 54 | :tess-eval (gl-in "gl_in"))) 55 | 56 | ((gl-position "gl_Position") :vec4) 57 | ((gl-point-size "gl_PointSize") :float) 58 | ((gl-clip-distance "gl_ClipDistance") (:float *)) ;; fixme: array syntax? 59 | ((gl-cull-distance "gl_CullDistance") (:float *))) ;; glsl 450 60 | 61 | ;; geometry 62 | (input (gl-primitive-id-in "gl_PrimitiveIDIn") :int :geometry) 63 | (input (gl-invocation-id "gl_InvocationID") :int :geometry) 64 | (output (gl-primitive-id "gl_PrimitiveID") :int :geometry) 65 | (output (gl-layer "gl_Layer") :int :geometry) ;; 430? 66 | (output (gl-viewport-index "gl_ViewportIndex") :int :geometry) ;; 430? 67 | 68 | ;; tessellation control 69 | (input (gl-patch-vertices-in "gl_PatchVerticesIn") :int :tess-control) 70 | (input (gl-primitive-id "gl_PrimitiveID") :int :tess-control) 71 | (input (gl-invocation-id "gl_InvocationID") :int :tess-control) 72 | (output (gl-tess-level-outer "gl_TessLevelOuter") (:float 4) :tess-control :patch) 73 | (output (gl-tess-level-inner "gl_TessLevelInner") (:float 2) :tess-control :patch) 74 | 75 | ;; tessellation evaluation 76 | (input (gl-patch-vertices-in "gl_PatchVerticesIn") :int :tess-eval) 77 | (input (gl-primitive-id "gl_PrimitiveID") :int :tess-eval) 78 | (input (gl-tess-coord "gl_TessCoord") :vec3 :tess-eval) 79 | (input (gl-tess-level-outer "gl_TessLevelOuter" (:float 4)) :tess-eval :patch) 80 | (input (gl-tess-level-inner "gl_TessLevelInner" (:float 2)) :tess-eval :patch) 81 | 82 | ;; fragment 83 | (input (gl-frag-coord "gl_FragCoord") :vec4 :fragment) 84 | (input (gl-front-facing "gl_FrontFacing") :bool :fragment) 85 | (input (gl-clip-distance "gl_ClipDistance") (:float *) :fragment) 86 | (input (gl-cull-distance "gl_CullDistance") (:float *) :fragment) ;; 450 87 | (input (gl-point-coord "gl_PointCoord") :vec2 :fragment) 88 | (input (gl-primitive-ID "gl_PrimitiveID") :int :fragment) 89 | (input (gl-sample-id "gl_SampleID") :int :fragment) 90 | (input (gl-sample-position "gl_SamplePosition") :vec2 :fragment) 91 | (input (gl-sample-mask-in "gl_SampleMaskIn") (:int *) :fragment) 92 | (input (gl-layer "gl_Layer") :int :fragment) ;; 430? 93 | (input (gl-viewport-index "gl_ViewportIndex") :int :fragment) ;; 430? 94 | (input (gl-helper-invocation "gl_HelperInvocation") :bool :fragment) ;; 450 95 | (output (gl-frag-depth "gl_FragDepth") :float :fragment) 96 | (output (gl-sample-mask "gl_SampleMask") (:int *) :fragment))) 97 | -------------------------------------------------------------------------------- /ir.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | 3 | ;; extra declarations for functions 4 | ;; IN,OUT,INOUT for function args 5 | ;; VALUES to declare return type of function 6 | 7 | 8 | ;;; special forms: 9 | 10 | ;; block/return-from -- not sure we can do this properly without a GOTO 11 | ;; might be able to get close with extracting blocks to separate 12 | ;; functions and using RETURN + special return values to mark returns 13 | ;; through nested scopes, but probably not worth the effort... 14 | ;; - for now, just using `(RETURN)` or `(RETURN-FROM name-of-function)` 15 | ;; as glsl `return` which exits entire function 16 | ;; throw/catch -- ignore 17 | ;; load-time-value -- ignore? 18 | ;; locally -- probably ignore? since we can't have variant types 19 | ;; in generated code, LOCALLY as best just makes type inference more 20 | ;; confusing... 21 | ;; function -- ignore? 22 | ;; not sure we can have function pointers, so ignore for now... 23 | ;; multiple-value-call -- ignore 24 | ;; multiple-value-prog1 -- ignore 25 | ;; progv -- ignore 26 | ;; quote -- ignore? (or expand during earlier pass if any meaningful uses?) 27 | ;; 28 | 29 | ;; unwind-protect -- ? 30 | 31 | ;; eval-when -- remove during early pass (eval compile time stuff, leave 32 | ;; load/execute stuff in code without eval-when) 33 | ;; symbol-macrolet -- expanded in earlier passes 34 | ;; macrolet -- expanded in earlier passes 35 | ;; flet/labels -- inline during earlier pass? 36 | ;; (or possibly extract to separate functions?) 37 | ;; can't have recursion though, so probably doesn't matter too much 38 | 39 | ;;; CL special forms included in IR 40 | 41 | ;; let 42 | ;; let* 43 | ;; setq 44 | ;; tagbody (probably best to avoid since it won't expand well) 45 | 46 | ;;; extra special forms 47 | ;; DO or DO* 48 | ;; possibly should just expand to FOR? 49 | ;; FOR 50 | ;; not sure if this should be exposed at CL level, or just 51 | ;; be there for LOOP/DO expansions? 52 | ;; hard to come up with a nice syntax to cover possiblity of mixing bindings 53 | ;; with non-binding expressions in init/test clauses? 54 | ;; DO-WHILE / WHILE-DO ? 55 | ;; similar issues to FOR, but might be worth adding a no-bindings 56 | ;; form anyway? 57 | ;; SWITCH ? 58 | ;; 59 | ;; RETURN/BREAK/CONTINUE/DISCARD 60 | ;; could probably pretend these are just builtin functions, but 61 | ;; might eventually want to be able to distinguish them for dead 62 | ;; code elimination etc 63 | 64 | 65 | ;; intermediate representation: 66 | ;; 67 | ;;; objects/mixins 68 | ;; 69 | ;; binding-scope mixin 70 | ;; bindings for a DEFUN or LET or LET* or FOR loop, set of bindings 71 | ;; + types + initial values 72 | ;; 73 | ;; variable write 74 | ;; variable read 75 | ;; local, global (varying, uniform, ?) 76 | ;; function call 77 | ;; builtin, global, ? 78 | ;; might want to distinguish between stuff like + that is 79 | ;; expanded by specially compiler, and other builtin functions 80 | ;; that expand to actual function calls? 81 | ;; 82 | ;; defun 83 | ;; 84 | ;; global var binding? 85 | ;; uniforms? 86 | ;; varyings? 87 | 88 | (defclass place () 89 | ()) 90 | 91 | (defmethod name (o) 92 | o) 93 | 94 | (defclass binding (place) 95 | ((name :accessor name :initarg :name) 96 | (glsl-name :accessor glsl-name :initarg :glsl-name :initform nil) 97 | ;; inferred type of variable or T if not known yet 98 | (value-type :accessor value-type :initarg :value-type 99 | :initform t) 100 | ;; most things allow implicit casts, but constructors explicitly allow 101 | ;; a larger set of other types, so we don't want to confuse things 102 | ;; by allowing casts in addition to that 103 | ;; (not sure if it affects correctness or not, but should be faster 104 | ;; and maybe reduce ambiguity) 105 | (allow-casts :accessor allow-casts :initform t :initarg :allow-casts) 106 | ;; T for unknown, or a type or a binding object to share a type 107 | ;; with another binding (for example functions that accept any type 108 | ;; as long as all arguments are same type, or where return type 109 | ;; matches an arg type) 110 | (declared-type :accessor declared-type :initarg :declared-type 111 | :initform t) 112 | (qualifiers :accessor qualifiers :initform nil :initarg :qualifiers) 113 | ;; set to true if variable needs renamed due to a scoping conflict 114 | ;; (for example shadows a variable used in initialization of 115 | ;; variable in same scope) 116 | (conflicts :accessor conflicts :initform nil))) 117 | 118 | (defclass binding-with-dependencies () 119 | ;; we need to track dependencies to allow automatic recompiling, but 120 | ;; not for all bindings (builtin functions/variables shouldn't be 121 | ;; changing for example, so we don't want them holding references to 122 | ;; old functions forever) 123 | ((bindings-used-by :reader bindings-used-by :initform (make-hash-table)) 124 | (bindings-using :reader bindings-using :initform (make-hash-table)))) 125 | 126 | (defclass initialized-binding (binding) 127 | ;; for actual variables in the code (global or local) 128 | ((initial-value-form :accessor initial-value-form :initarg :init))) 129 | 130 | (defclass variable-binding (initialized-binding) 131 | ()) 132 | 133 | (defclass constant-binding (initialized-binding binding-with-dependencies) 134 | ((internal :accessor internal :initform nil))) 135 | 136 | (defmethod initialize-instance :after ((i constant-binding) 137 | &key &allow-other-keys) 138 | (pushnew :const (qualifiers i))) 139 | 140 | (defclass local-variable (variable-binding) 141 | ()) 142 | 143 | (defclass global-variable (variable-binding binding-with-dependencies) 144 | ()) 145 | 146 | (defclass symbol-macro (binding) 147 | ((expansion :accessor expansion :initarg :expansion))) 148 | 149 | ;; not sure if this needs to be distinct? 150 | (defclass function-argument (local-variable) 151 | ()) 152 | 153 | 154 | (defclass progn-body () ;; mixin for forms with (implicit) progn 155 | ;; possibly should have a subclass for explicit progn, so we can 156 | ;; distinguish that from implicit progns? (so we can do things 157 | ;; like merging nested progns) 158 | ;; alternately, might be better to just make all progns explicit? 159 | ((body :accessor body :initarg :body))) 160 | 161 | (defclass explicit-progn (progn-body) 162 | ()) 163 | (defclass implicit-progn (progn-body) 164 | ()) 165 | 166 | (defclass bindings () 167 | ;; list (sequence?) of bindings corresponding to a let scope, 168 | ;; function arglist, etc 169 | ((bindings :accessor bindings :initarg :bindings))) 170 | 171 | (defclass binding-scope (bindings implicit-progn) ;; let/let* 172 | ((declarations :initarg :declarations :accessor declarations))) 173 | 174 | 175 | (defclass function-binding () 176 | ;; bindings in function namespace 177 | ((name :accessor name :initarg :name) 178 | (glsl-name :accessor glsl-name :initarg :glsl-name :initform nil) 179 | (declarations :initarg :declarations :accessor declarations) 180 | (docs :initarg :docs) 181 | ;; inferred type of variable or T if not known yet 182 | (value-type :accessor value-type :initarg :value-type 183 | :initform t) 184 | ;; T for unknown, or a type or a binding object to share a type 185 | ;; with another binding (for example functions that accept any type 186 | ;; as long as all arguments are same type, or where return type 187 | ;; matches an arg type) 188 | (declared-type :accessor declared-type :initarg :declared-type 189 | :initform t))) 190 | 191 | (defclass function-binding-function (function-binding binding-with-dependencies) 192 | ;; todo: add some way to detect changes in type inference data 193 | ;; so we don't need to redo type inference for callers if not needed? 194 | ;; not sure how often they will actually be similar enough though, 195 | ;; so might not actually be worth it? 196 | (;; nil = not run yet, t = OK, :failed = unknown globals or type 197 | ;; conflicts (possibly should also distinguish between resolved to 198 | ;; single types or not?) 199 | (type-inference-state :initform nil :accessor type-inference-state 200 | :initarg :type-inference-state) 201 | ;; T or list of names of stages in which the function is valid 202 | ;; (not automatically updated when things are defined in more stages 203 | ;; that might make it valid, so possibly should try recompiling if 204 | ;; used from a different stage) 205 | ;; used by type inference to decide which stages to run inference for 206 | ;; fixme: is this actually used/useful? 207 | (valid-stages :initform t :accessor valid-stages :initarg :valid-stages) 208 | ;; 'type' object for each local binding inside the function 209 | ;; including arguments (keyed by binding object) 210 | ;; and return value (keyed by :return) 211 | ;; as well as an entry for every call to a global-function 212 | ;; (keyed by an inference-call-site object or something like that 213 | ;; with list of types (ret then supplied arg types) as value) 214 | ;; only valid after type inference is run, should be empty otherwise 215 | ;; probably not concrete types for most functions, since types 216 | ;; depend on argument types. (specific types are chosen during final 217 | ;; compile for any sets of argument types actually used) 218 | (local-binding-type-data :initform (make-hash-table) 219 | :accessor local-binding-type-data) 220 | ;; concrete type data for any overloaded versions of this function 221 | ;; which have been computer so far, keyed by a list of concrete types 222 | ;; value is hash table like local-binding-type-data, except with 223 | ;; a list of lists of arg types for inference-call-site entries 224 | ;; (only calculated as needed, so only contains data for combinations 225 | ;; actually compiled since function was last modified) 226 | (final-binding-type-cache :initform (make-hash-table :test 'equal) 227 | :accessor final-binding-type-cache) 228 | ;; sexp lambda list (with &key, etc) 229 | ;; (no &rest though, since we don't have lists) 230 | (lambda-list :initarg :lambda-list :accessor lambda-list) 231 | (old-lambda-list :initform t :accessor old-lambda-list) 232 | ;; to support &key args, we optionally have a sort of compiler-macro 233 | ;; associated with functions, to expand keyword args in the source 234 | ;; into positional args 235 | ;; todo: check for reordering argument values with side effects and warn 236 | ;; (since we might epand something like (foo :a a :b b) into (foo b a) 237 | ;; which could matter if A or B modify the same variable, or one 238 | ;; modifies a variable the other depends on) 239 | ;; todo: compile this lazily like macros? (and maybe combine with them?) 240 | (expander :accessor expander :initarg :expander :initform #'identity) 241 | ;; 'layout' qualifiers for shader with this function as 'main' 242 | (layout-qualifiers :accessor layout-qualifiers :initform (make-hash-table)))) 243 | 244 | (defun function-signature-changed (fun) 245 | ;; todo: ignore changed names (but keep changed defaults, so can't 246 | ;; just look at shape of tree) 247 | (not (equal (lambda-list fun) (old-lambda-list fun)))) 248 | 249 | #++ 250 | (defun function-type-changed (fun) 251 | (not (equal (function-type fun) (old-function-type fun)))) 252 | 253 | (defclass global-function (function-binding-function implicit-progn bindings) 254 | ;; global function definitions, with function body 255 | ()) 256 | 257 | (defclass unknown-function-binding (function-binding binding-with-dependencies) 258 | ;; reference to an unknown function, will be CHANGE-CLASSed to 259 | ;; function-binding-function when defined 260 | ;; store onvironment that was current when the reference was made, 261 | ;; so we can check there, will also check for an environment in 262 | ;; symbol-package of function's name 263 | ;; (probably should be in package's 264 | ((environment :accessor environment :initarg :environment))) 265 | 266 | (defclass builtin-function (function-binding-function bindings) 267 | ;; declarations for functions provided by glsl 268 | ;; (or external glsl code) 269 | ()) 270 | 271 | (defclass internal-function (function-binding-function bindings) 272 | ;; like a builtin function, but we compile it specially 273 | ;; for example AND -> &&, etc 274 | ;; probably mostly CL functions? 275 | () 276 | (:default-initargs :type-inference-state t)) 277 | 278 | ;; we also have macros and local functions during early passes.. 279 | (defclass macro-definition (function-binding) 280 | ;; we store expression to compile for macro, and only compile the 281 | ;; actual macro function the first time it is used 282 | ((expression :accessor expression :initarg :expression) 283 | (expander :accessor expander :initform nil))) 284 | 285 | ;; not sure we need to distinguish global from local macros, since local 286 | ;; macros shoul only exist in transient environment scopes? 287 | #++ 288 | (defclass global-macro (macro-definition) 289 | ()) 290 | #++ 291 | (defclass local-macro (macro-definition) 292 | ()) 293 | 294 | 295 | ;;; not supporting bindings in FOR loops for now, since they aren't 296 | ;;; really very general (we can bind multiple variables in 297 | ;;; 'init-expression' but only if they are all the same type, and we 298 | ;;; can't mix bindings and non-binding expressions, etc) 299 | ;;; instead we can just wrap it in a LET and let it expand to 300 | ;; `{ for (...) {...} }` 301 | ;;; and if we really want to, later expand the simple cases to 302 | ;;; `for (...) {...}` if we care about the generated code 303 | (defclass for-loop (implicit-progn) 304 | ((init-forms :accessor init-forms :initarg :init) 305 | (condition-forms :accessor condition-forms :initarg :while) 306 | (step-forms :accessor step-forms :initarg :step))) 307 | 308 | 309 | ;; slot/array access are used like bindings for now, might need to be 310 | ;; smarter once we start type inference? 311 | (defclass slot-access (place) 312 | ((binding :accessor binding :initarg :binding) 313 | (field :accessor field :initarg :field) 314 | (value-type :accessor value-type :initarg :value-type))) 315 | (defclass swizzle-access (place) 316 | ((binding :accessor binding :initarg :binding) 317 | (field :accessor field :initarg :field) 318 | (min-size :accessor min-size :initarg :min-size) 319 | (value-type :accessor value-type :initarg :value-type))) 320 | (defclass array-access (place) 321 | ((binding :accessor binding :initarg :binding) 322 | (index :accessor index :initarg :index) 323 | (value-type :accessor value-type :initarg :value-type))) 324 | (defmethod name ((o slot-access)) 325 | (name (binding o))) 326 | (defmethod name ((o swizzle-access)) 327 | (list (name (binding o)) (field o))) 328 | (defmethod name ((o array-access)) 329 | (list (name (binding o)) '[ (index o) '])) 330 | 331 | 332 | (defclass variable-read (place) 333 | ;; possibly should store some type info as well? 334 | ((binding :accessor binding :initarg :binding))) 335 | (defmethod name ((o variable-read)) 336 | (name (binding o))) 337 | (defmethod value-type ((o variable-read)) 338 | (value-type (binding o))) 339 | 340 | (defclass variable-write () 341 | ;; possibly should store some type info as well? 342 | ((binding :accessor binding :initarg :binding) 343 | (value :accessor value :initarg :value))) 344 | (defmethod name ((o variable-write)) 345 | (name (binding o))) 346 | 347 | (defclass function-call () 348 | ((called-function :accessor called-function :initarg :function) 349 | (arguments :accessor arguments :initarg :arguments) 350 | ;; we need to store enough information to recompile 351 | ;; calls when called function is (re)defined, since we expand 352 | ;; &key and such at the call site 353 | (raw-arguments :accessor raw-arguments :initarg :raw-arguments) 354 | (argument-environment :accessor argument-environment 355 | :initarg :argument-environment))) 356 | (defmethod name ((o function-call)) 357 | (name (called-function o))) 358 | 359 | ;; hack for array initialization, (vector a b c ...) prints as {a,b,c,...} 360 | (defclass array-initialization (array-type) 361 | ((arguments :accessor arguments :initarg :arguments) 362 | (raw-arguments :accessor raw-arguments :initarg :raw-arguments) 363 | (argument-environment :accessor argument-environment 364 | :initarg :argument-environment))) 365 | (defclass if-form () 366 | ((test-form :accessor test-form :initarg :test) 367 | (then-form :accessor then-form :initarg :then) 368 | (else-form :accessor else-form :initarg :else))) 369 | 370 | 371 | 372 | ;;; these don't assign results of walking children back into parent, since 373 | ;;; other objects might refer to them... if we really need to make changes, 374 | ;;; try change-class or something? 375 | 376 | (defmethod walk ((form initialized-binding) walker) 377 | (walk (initial-value-form form) walker) 378 | (when (next-method-p) 379 | (call-next-method))) 380 | 381 | (defmethod walk ((form array-initialization) walker) 382 | (loop for i in (arguments form) 383 | do (walk i walker)) 384 | (when (next-method-p) 385 | (call-next-method))) 386 | 387 | (defmethod walk ((form function-call) walker) 388 | (loop for i in (arguments form) 389 | do (walk i walker)) 390 | (when (next-method-p) 391 | (call-next-method))) 392 | 393 | (defmethod walk ((form progn-body) walker) 394 | (loop for i in (body form) 395 | do (walk i walker)) 396 | (when (next-method-p) 397 | (call-next-method))) 398 | 399 | (defmethod walk ((form bindings) walker) 400 | (loop for i in (bindings form) 401 | do (walk i walker)) 402 | (when (next-method-p) 403 | (call-next-method))) 404 | 405 | (defmethod walk ((form array-access) walker) 406 | (walk (binding form) walker) 407 | (walk (index form) walker) 408 | (when (next-method-p) 409 | (call-next-method))) 410 | 411 | (defmethod walk ((form slot-access) walker) 412 | (walk (binding form) walker) 413 | (when (next-method-p) 414 | (call-next-method))) 415 | 416 | (defmethod walk ((form variable-read) walker) 417 | (walk (binding form) walker) 418 | (when (next-method-p) 419 | (call-next-method))) 420 | 421 | (defmethod walk ((form variable-write) walker) 422 | (walk (binding form) walker) 423 | (walk (value form) walker) 424 | (when (next-method-p) 425 | (call-next-method))) 426 | 427 | (defmethod walk ((form if-form) walker) 428 | (walk (test-form form) walker) 429 | (walk (then-form form) walker) 430 | (walk (else-form form) walker)) 431 | -------------------------------------------------------------------------------- /old-utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | ;;; some brain-dead utils for shader-related stuff (recompiling 3 | ;;; shaders, setting uniforms by name, etc) 4 | 5 | 6 | (defun uniform-index (program name) 7 | (if program 8 | (gl:get-uniform-location program name) 9 | -1)) 10 | 11 | (defun uniformi (program name value) 12 | (gl:uniformi (uniform-index program name) value)) 13 | 14 | (defun uniformf (program name x &optional y z w) 15 | (let ((u (uniform-index program name))) 16 | (unless (minusp u) 17 | (cond 18 | (w (%gl:uniform-4f u (float x) (float y) (float z) (float w))) 19 | (z (%gl:uniform-3f u (float x) (float y) (float z))) 20 | (y (%gl:uniform-2f u (float x) (float y))) 21 | (x (%gl:uniform-1f u (float x))))))) 22 | 23 | (defun uniformfv (program name v) 24 | (let ((u (uniform-index program name))) 25 | (unless (minusp u) 26 | (typecase v 27 | ;; fast cases 28 | ((vector single-float 3) 29 | (%gl:uniform-3f u (aref v 0) (aref v 1) (aref v 2))) 30 | ((vector single-float 4) 31 | (%gl:uniform-4f u (aref v 0) (aref v 1) (aref v 2) (aref v 3))) 32 | ;; convenient but slower cases 33 | ((vector * 4) 34 | (%gl:uniform-4f u (float (elt v 0) 1.0) (float (elt v 1) 1.0) 35 | (float (elt v 2) 1.0) (float (elt v 3) 1.0))) 36 | ((vector * 3) 37 | (%gl:uniform-3f u (float (elt v 0) 1.0) (float (elt v 1) 1.0) 38 | (float (elt v 2) 1.0))) 39 | ((vector * 2) 40 | (%gl:uniform-2f u (float (elt v 0) 1.0) (float (elt v 1) 1.0))) 41 | 42 | ((vector * 1) 43 | (%gl:uniform-1f u (float (elt v 0) 1.0))) 44 | 45 | )))) 46 | 47 | (defun uniform-matrix (program name m) 48 | (let ((u (uniform-index program name))) 49 | (unless (minusp u) 50 | (gl:uniform-matrix u 4 (vector m) nil)))) 51 | 52 | 53 | 54 | (defun reload-program (old v f &key errorp (verbose t) geometry (version 450)) 55 | "compile program from shaders named by V and F, on success, delete 56 | program OLD and return new program, otherwise return OLD" 57 | ;; intended to be used like 58 | ;; (setf (program foo) (reload-program (program foo) 'vertex 'frag)) 59 | (let ((vs (gl:create-shader :vertex-shader)) 60 | (fs (gl:create-shader :fragment-shader)) 61 | (gs (when geometry (gl:create-shader :geometry-shader))) 62 | (program (gl:create-program)) 63 | (uniformh (make-hash-table))) 64 | (unwind-protect 65 | (flet ((c (stage entry) 66 | (multiple-value-bind (source uniforms attributes buffers 67 | structs) 68 | (3bgl-shaders::generate-stage stage entry 69 | :version version) 70 | (declare (ignorable attributes buffers structs)) 71 | (loop for u in uniforms 72 | for (l g tt) = u 73 | for o = (gethash l uniformh) 74 | when (and o (not (equalp u o))) 75 | do (format t "duplicate uniform ~s -> ~s~%?" o u) 76 | do (setf (gethash l uniformh) 77 | (cons -1 u))) 78 | source)) 79 | (try-shader (shader source) 80 | (when *print-shaders* 81 | (format t "generating shader ~s~%" shader) 82 | (format t "~s~%" source)) 83 | (gl:shader-source shader source) 84 | (gl:compile-shader shader) 85 | (cond 86 | ((gl:get-shader shader :compile-status) 87 | (gl:attach-shader program shader)) 88 | (errorp 89 | (error "shader compile failed: ~s" (gl:get-shader-info-log shader))) 90 | (t 91 | (when verbose 92 | (format verbose "shader compile failed: ~s" (gl:get-shader-info-log shader))) 93 | (return-from reload-program old))))) 94 | (try-shader vs (c :vertex v)) 95 | (try-shader fs (c :fragment f)) 96 | (when gs 97 | (try-shader gs (c :geometry geometry))) 98 | (gl:link-program program) 99 | (cond 100 | ((gl:get-program program :link-status) 101 | ;; if it linked, swap with old program so we delete that on uwp 102 | (rotatef old program)) 103 | (errorp 104 | (error "program link failed ~s" 105 | (gl:get-program-info-log program))) 106 | (t 107 | (when verbose 108 | (format verbose "program link failed: ~s" (gl:get-program-info-log program)))))) 109 | ;; clean up on exit 110 | (gl:delete-shader vs) 111 | (gl:delete-shader fs) 112 | ;; PROGRAM is either program we just tried to link, or previous one if 113 | ;; link succeeded 114 | (when program 115 | (gl:delete-program program))) 116 | (when old 117 | (loop for u being the hash-keys of uniformh 118 | for n = (third (gethash u uniformh)) 119 | do (setf (car (gethash u uniformh)) 120 | (uniform-index old n)))) 121 | (values old uniformh))) 122 | 123 | (defparameter *normalize-shader-types* 124 | (alexandria:plist-hash-table 125 | '(:vertex :vertex-shader 126 | :fragment :fragment-shader 127 | :geometry :geometry-shader 128 | :tess-control :tess-control-shader 129 | :tess-eval :tess-evaluation-shader 130 | :compute :compute-shader))) 131 | 132 | (defun reload-program* (old stages &key errorp (verbose t) (version 450) 133 | (print *print-shaders*)) 134 | "compile program from STAGES, a plist of stage names and entry 135 | points. on success, delete program OLD and return new program, 136 | otherwise return OLD" 137 | ;; intended to be used like 138 | ;; (setf (program foo) (reload-program (program foo) '(:vertex v :fragment f)) 139 | (let ((shaders ()) 140 | (program (gl:create-program)) 141 | (uniformh (make-hash-table))) 142 | (unwind-protect 143 | (labels ((c (stage entry) 144 | (multiple-value-bind (source uniforms attributes buffers 145 | structs) 146 | (3bgl-shaders::generate-stage stage entry 147 | :version version) 148 | (declare (ignorable attributes buffers structs)) 149 | (loop for u in uniforms 150 | for (l g tt) = u 151 | for o = (gethash l uniformh) 152 | when (and o (not (equalp u o))) 153 | do (format t "duplicate uniform ~s -> ~s~%?" o u) 154 | do (setf (gethash l uniformh) 155 | (cons -1 u))) 156 | source)) 157 | (try-shader (stage entry-point) 158 | (let ((source (c stage entry-point)) 159 | (shader (gl:create-shader stage))) 160 | (push shader shaders) 161 | (when print 162 | (format t "generating shader ~s~%" shader) 163 | (format t "~s~%" source)) 164 | (gl:shader-source shader source) 165 | (gl:compile-shader shader) 166 | (cond 167 | ((gl:get-shader shader :compile-status) 168 | (gl:attach-shader program shader)) 169 | (errorp 170 | (error "shader compile failed: ~s" (gl:get-shader-info-log shader))) 171 | (t 172 | (when verbose 173 | (format verbose "shader compile failed: ~s" (gl:get-shader-info-log shader))) 174 | (return-from reload-program* old)))))) 175 | (loop for (.stage entry) on stages by #'cddr 176 | for stage = (gethash .stage *normalize-shader-types* .stage) 177 | do (try-shader stage entry)) 178 | (gl:link-program program) 179 | (cond 180 | ((gl:get-program program :link-status) 181 | ;; if it linked, swap with old program so we delete that on uwp 182 | (rotatef old program)) 183 | (errorp 184 | (error "program link failed ~s" 185 | (gl:get-program-info-log program))) 186 | (t 187 | (when verbose 188 | (format verbose "program link failed: ~s" (gl:get-program-info-log program)))))) 189 | ;; clean up on exit 190 | (map 'nil 'gl:delete-shader shaders) 191 | ;; PROGRAM is either program we just tried to link, or previous one if 192 | ;; link succeeded 193 | (when program 194 | (gl:delete-program program))) 195 | (when old 196 | (loop for u being the hash-keys of uniformh 197 | for n = (third (gethash u uniformh)) 198 | do (setf (car (gethash u uniformh)) 199 | (uniform-index old n)))) 200 | (values old uniformh))) 201 | 202 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:3bgl-shaders 2 | (:use :cl) 3 | (:intern #:%glsl-macro 4 | #:*package-environments* 5 | #:ensure-package-environment) 6 | (:export 7 | :layout 8 | :in 9 | :out 10 | :inout 11 | :generate-stage 12 | :compile-form 13 | :stage 14 | :*modified-function-hook* 15 | :*default-version*)) 16 | 17 | (defpackage #:3bgl-glsl 18 | (:use :cl) 19 | (:shadow #:defun 20 | #:defconstant 21 | #:defmacro 22 | #:defstruct) 23 | (:import-from #:3bgl-shaders 24 | #:layout 25 | #:in 26 | #:out 27 | #:inout 28 | #:stage 29 | #:%glsl-macro 30 | #:*package-environments* 31 | #:ensure-package-environment) 32 | (:export 33 | ;; shadowed from CL 34 | #:defun 35 | #:defmacro 36 | #:defconstant 37 | #:defstruct 38 | 39 | ;; ?? 40 | #:generate-stage 41 | #:glsl-defun 42 | #:glsl-interface 43 | #:glsl-attribute 44 | #:glsl-output 45 | #:glsl-input 46 | #:glsl-uniform 47 | #:glsl-defconstant 48 | 49 | ;; glsl-side API 50 | #:layout 51 | #:in 52 | #:out 53 | #:inout 54 | #:interface 55 | #:attribute 56 | #:output 57 | #:@ 58 | #:input 59 | #:uniform 60 | #:shared 61 | #:bind-interface 62 | #:stage 63 | 64 | ;; predefined constants 65 | #:gl-vertex-id 66 | #:gl-instance-id 67 | #:gl-draw-id 68 | #:gl-base-vertex 69 | #:gl-base-instance 70 | #:gl-per-vertex 71 | #:gl_out ;;? 72 | #:gl_in ;;? 73 | #:gl-in 74 | #:gl-position 75 | #:gl-point-size 76 | #:gl-clip-distance 77 | #:gl-primitive-id-in 78 | #:gl-invocation-id 79 | #:gl-primitive-id 80 | #:gl-layer 81 | #:gl-viewport-index 82 | #:gl-patch-vertices-in 83 | #:gl-tess-level-outer 84 | #:gl-tess-level-inner 85 | #:gl-tess-coord 86 | #:gl-frag-coord 87 | #:gl-front-facing 88 | #:gl-point-coord 89 | #:gl-sample-id 90 | #:gl-sample-position 91 | #:gl-sample-mask-in 92 | #:gl-frag-depth 93 | #:gl-sample-mask 94 | #:gl-num-work-groups 95 | #:gl-work-group-size 96 | #:gl-work-group-id 97 | #:gl-local-invocation-id 98 | #:gl-global-invocation-id 99 | #:gl-local-invocation-index 100 | 101 | ;; built-in glsl functions 102 | ;; many of these are just reexported from CL#: though meaning might 103 | ;; differe a bit 104 | 105 | #:<< 106 | #:>> 107 | #:^^ 108 | #:radians 109 | #:degrees 110 | #:sin 111 | #:cos 112 | #:tan 113 | #:asin 114 | #:acos 115 | #:atan 116 | #:sinh 117 | #:cosh 118 | #:tanh 119 | #:asinh 120 | #:acosh 121 | #:atanh 122 | #:pow 123 | #:exp 124 | #:log 125 | #:exp2 126 | #:log2 127 | #:sqrt 128 | #:inverse-sqrt 129 | #:abs 130 | #:signum 131 | #:sign 132 | #:floor 133 | #:truncate 134 | #:trunc 135 | #:round 136 | #:round-even 137 | #:ceiling 138 | #:ceil 139 | #:fract 140 | #:mod 141 | #:modf 142 | #:min 143 | #:max 144 | #:clamp 145 | #:mix 146 | #:step 147 | #:smooth-step 148 | #:is-nan 149 | #:is-inf 150 | #:float-bits-to-int 151 | #:float-bits-to-uint 152 | #:int-bits-to-float 153 | #:uint-bits-to-float 154 | #:fma 155 | #:frexp 156 | #:ldexp 157 | ;; 8.4 floating-point pack and unpack functions 158 | #:pack-unorm-2x16 159 | #:pack-snorm-2x16 160 | #:pack-unorm-4x8 161 | #:pack-snorm-4x8 162 | #:unpack-unorm-2x16 163 | #:unpack-snorm-2x16 164 | #:unpack-unorm-4x8 165 | #:unpack-snorm-4x8 166 | #:pack-double-2x32 167 | #:unpack-double-2x32 168 | #:pack-half-2x16 169 | #:unpack-half-2x16 170 | ;; 8.5 geometric functions 171 | #:length 172 | #:distance 173 | #:dot 174 | #:cross 175 | #:normalize 176 | ;; compat/vertex shader only 177 | #:ftransform 178 | #:face-forward 179 | #:reflect 180 | #:refract 181 | ;; 8.6 matrix functions 182 | #:matrix-comp-mult 183 | #:outer-product 184 | #:transpose 185 | #:determinant 186 | #:inverse 187 | ;; 8.7 vector relational functions 188 | #:less-than 189 | #:less-than-equal 190 | #:greater-than 191 | #:greater-than-equal 192 | #:equal 193 | #:not-equal 194 | #:any 195 | #:all 196 | ;; 8.8 integer functions 197 | #:uadd-carry 198 | #:usub-borrow 199 | #:umul-extended 200 | #:imul-extended 201 | #:bitfield-extract 202 | #:bitfield-insert 203 | #:bitfield-reverse 204 | #:bit-count 205 | #:find-lsb 206 | #:find-msb 207 | ;; 8.9 Texture Functions 208 | #:texture-size 209 | #:texture-query-lod 210 | #:texture-query-levels 211 | #:texture-samples 212 | #:texture 213 | #:texture-proj 214 | #:texture-lod 215 | #:texture-offset 216 | #:texel-fetch 217 | #:texel-fetch-offset 218 | #:texture-proj-offset 219 | #:texture-lod-offset 220 | #:texture-proj-lod 221 | #:texture-proj-lod-offset 222 | #:texture-grad 223 | #:texture-grad-offset 224 | #:texture-proj-grad 225 | #:texture-proj-grad-offset 226 | ;; 8.9.3 texture gather functions 227 | #:texture-gather 228 | #:texture-gather-offset 229 | #:texture-gather-offsets 230 | ;; 8.9.4 compatibility profile 231 | #:texture-1d 232 | #:texture-1d-proj 233 | #:texture-1d-lod 234 | #:texture-1d-proj-lod 235 | #:texture-2d 236 | #:texture-2d-proj 237 | #:texture-2d-lod 238 | #:texture-2d-proj-lod 239 | #:texture-3d 240 | #:texture-3d-proj 241 | #:texture-3d-lod 242 | #:texture-3d-proj-lod 243 | #:texture-cube 244 | #:texture-cube-lod 245 | #:shadow-1d 246 | #:shadow-2d 247 | #:shadow-1d-proj 248 | #:shadow-2d-proj 249 | #:shadow-1d-lod 250 | #:shadow-2d-lod 251 | #:shadow-1d-proj-lod 252 | #:shadow-2d-proj-lod 253 | ;; 8.10 atomic-counter functions 254 | #:atomic-counter-increment 255 | #:atomic-counter-decrement 256 | #:atomic-counter 257 | ;; 8.11 atomic memory functions 258 | #:atomic-add 259 | #:atomic-min 260 | #:atomic-max 261 | #:atomic-and 262 | #:atomic-or 263 | #:atomic-xor 264 | #:atomic-exchange 265 | #:atomic-comp-swap 266 | ;; 8.12 Image functions 267 | #:image-size 268 | #:image-samples 269 | #:image-load 270 | #:image-store 271 | #:image-atomic-add 272 | #:image-atomic-min 273 | #:image-atomic-max 274 | #:image-atomic-and 275 | #:image-atomic-or 276 | #:image-atomic-xor 277 | #:image-atomic-exchange 278 | #:image-atomic-comp-swap 279 | ;; 8.13 fragment processing functions 280 | ;; 8.13.1 derivative functions 281 | #:dfdx 282 | #:dfdy 283 | #:dfdx-fine 284 | #:dfdy-fine 285 | #:dfdx-coarse 286 | #:dfdy-coarse 287 | #:fwidth 288 | #:fwidth-fine 289 | #:fwidth-coarse 290 | ;; 8.13.2 interpolation functions 291 | ;; these specify float/vec2/vec3/vec4 explicitly instead of gentype? 292 | #:interpolate-at-centroid 293 | #:interpolate-at-sample 294 | #:interpolate-at-centroid 295 | ;; 8.14 noise functions 296 | #:noise1 297 | #:noise2 298 | #:noise3 299 | #:noise4 300 | ;; 8.15 geometry shader functions 301 | #:emit-stream-vertex 302 | #:end-stream-primitive 303 | #:emit-vertex 304 | #:end-primitive 305 | ;; 8.16 shader invocation control functions 306 | #:barrier 307 | ;; 8.17 Shader memory control functions 308 | #:memory-barrier 309 | #:memory-barrier-atomic-counter 310 | #:memory-barrier-buffer 311 | #:memory-barrier-shared 312 | #:memory-barrier-image 313 | #:group-memory-barrier 314 | ;; 8.19 Shader Invocation Group Functions 315 | #:any-invocation 316 | #:all-invocations 317 | #:all-invocations-equal 318 | 319 | ;; vector/matrix constructors 320 | #:int8 321 | #:int16 322 | #:int 323 | #:int64 324 | #:uint8 325 | #:uint16 326 | #:uint 327 | #:uint64 328 | #:bool 329 | #:float 330 | #:double 331 | #:bvec2 332 | #:bvec3 333 | #:bvec4 334 | #:i8vec2 335 | #:i8vec3 336 | #:i8vec4 337 | #:u8vec2 338 | #:u8vec3 339 | #:u8vec4 340 | #:i16vec2 341 | #:i16vec3 342 | #:i16vec4 343 | #:u16vec2 344 | #:u16vec3 345 | #:u16vec4 346 | #:ivec2 347 | #:ivec3 348 | #:ivec4 349 | #:uvec2 350 | #:uvec3 351 | #:uvec4 352 | #:i64vec2 353 | #:i64vec3 354 | #:i64vec4 355 | #:u64vec2 356 | #:u64vec3 357 | #:u64vec4 358 | #:f16vec2 359 | #:f16vec3 360 | #:f16vec4 361 | #:vec2 362 | #:vec3 363 | #:vec4 364 | #:dvec2 365 | #:dvec3 366 | #:dvec4 367 | #:f16mat2 368 | #:f16mat2x3 369 | #:f16mat2x4 370 | #:f16mat3x2 371 | #:f16mat3 372 | #:f16mat3x4 373 | #:f16mat4x2 374 | #:f16mat4x3 375 | #:f16mat4 376 | #:mat2 377 | #:mat2x3 378 | #:mat2x4 379 | #:mat3x2 380 | #:mat3 381 | #:mat3x4 382 | #:mat4x2 383 | #:mat4x3 384 | #:mat4 385 | #:dmat2 386 | #:dmat2x3 387 | #:dmat2x4 388 | #:dmat3x2 389 | #:dmat3 390 | #:dmat3x4 391 | #:dmat4x2 392 | #:dmat4x3 393 | #:dmat4 394 | ;; misc 395 | #:discard 396 | )) 397 | 398 | ;;; package intended to be :USEd by shader code in place of :cl 399 | ;;; exports all symbols from 3bgl-glsl, and any CL symbols not 400 | ;;; shadowed by it 401 | ;;; FIXME: probably should rename this one 3BGL-GLSL, and give the internal package the longer name? 402 | (defpackage #:3bgl-glsl/cl 403 | (:use #:cl #:3bgl-glsl) 404 | (:shadowing-import-from #:3bgl-glsl #:defun #:defconstant 405 | #:defmacro #:defstruct) 406 | #. (cons :export 407 | (flet ((externals (x) 408 | (let ((a)) 409 | (do-external-symbols (s x) 410 | (push s a)) 411 | a))) 412 | (append (externals '#:3bgl-glsl) 413 | (loop for s in (externals '#:cl) 414 | unless 415 | (eq :external 416 | (nth-value 1 (find-symbol (symbol-name s) 417 | '#:3bgl-glsl))) 418 | collect s))))) 419 | 420 | -------------------------------------------------------------------------------- /printer.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | 3 | (defparameter *in-expression* nil) 4 | 5 | ;; hack to rename a specific function as 'main' when printing, so we 6 | ;; can define a bunch of shaders for different stages (or different 7 | ;; features) in same package without worrying about which can be named 8 | ;; MAIN. 9 | (defparameter *print-as-main* nil) 10 | 11 | ;; we need to rename variables in some cases to avoid conflicts so 12 | ;; track which variables are live to avoid creating other conflicts in 13 | ;; the process 14 | ;; glsl name -> lisp symbol 15 | (defparameter *live-variables* (make-hash-table :test 'equal)) 16 | 17 | ;; we want to use call-next-method to print mixins, so using a custom 18 | ;; print function rather than pprint-dispatch stuff... 19 | 20 | (defgeneric %print (object stream)) 21 | (defmethod %print (object stream) 22 | ;; do nothing by default 23 | ) 24 | 25 | ;; but we want to hook into normal printing, so we add to the pprint 26 | ;; dispatch table and call %print from there 27 | (defparameter *pprint-glsl* (copy-pprint-dispatch nil)) 28 | 29 | 30 | 31 | (defun %translate-name (x &key lc-underscore) 32 | ;; todo: lookup name in environment to allow for specifying a translation 33 | (unless (stringp x) 34 | (setf x (string x))) 35 | (with-output-to-string (s) 36 | ;; fixme: smarter translation, filter more characters, etc 37 | (if (char= #\+ (char x 0) (char x (1- (length x)))) 38 | (with-standard-io-syntax 39 | (format s "~:@(~a~)" (substitute #\_ #\- (remove #\+ x)))) 40 | (if lc-underscore 41 | (format s "~(~a~)" (substitute #\_ #\- (remove #\+ x))) 42 | (loop with uc = 0 43 | for c across (string x) 44 | do (case c 45 | (#\* (incf uc 1)) 46 | (#\- (incf uc 1)) 47 | (#\+ 48 | (incf uc 1) 49 | (format s "_")) 50 | (#\% (format s "_")) 51 | (t (if (plusp uc) 52 | (format s "~:@(~c~)" c) 53 | (format s "~(~c~)" c)) 54 | (setf uc (max 0 (1- uc)))))))))) 55 | 56 | (defmethod translate-name (x) 57 | (%translate-name x)) 58 | 59 | (defmethod translate-name ((x binding)) 60 | (let ((n (or (glsl-name x) (%translate-name (name x))))) 61 | (when (or (conflicts x) 62 | (and (gethash n *live-variables*) 63 | (not (eq (name (gethash n *live-variables*)) (name x))))) 64 | (loop for i from 2 below 1000 65 | for rn = (format nil "~a_~a" n i) 66 | for c = (gethash rn *live-variables*) 67 | while (and c (not (eq c x))) 68 | finally (setf n rn))) 69 | n)) 70 | 71 | (defmethod translate-name ((x function-binding)) 72 | (if (eq x *print-as-main*) 73 | "main" 74 | (or (glsl-name x) (%translate-name (name x))))) 75 | 76 | (defmethod translate-name ((x slot-access)) 77 | (format nil "~a.~a" (binding x) 78 | (translate-slot-name (field x) (binding x)))) 79 | 80 | (defmethod translate-name ((x swizzle-access)) 81 | (format nil "~a.~a" (binding x) 82 | (translate-slot-name (field x) (binding x)))) 83 | 84 | (defmethod translate-name ((x array-access)) 85 | (format nil "~a[~a]" (binding x) 86 | (index x))) 87 | 88 | (defmethod translate-slot-name (x b) 89 | (%translate-name x)) 90 | 91 | 92 | (defmethod translate-slot-name (x (b variable-read)) 93 | (or (translate-slot-name x (binding b)) 94 | (%translate-name x))) 95 | 96 | (defmethod translate-slot-name (x (b array-access)) 97 | (or (translate-slot-name x (binding b)) 98 | (%translate-name x))) 99 | 100 | (defmethod translate-slot-name (x (b interface-binding)) 101 | (or (translate-slot-name x (stage-binding b)) 102 | (%translate-name x))) 103 | 104 | (defmethod translate-slot-name (x (b interface-stage-binding)) 105 | (when (or (interface-block b) (typep (binding b) 'bindings)) 106 | (let ((b2 (bindings (or (interface-block b) (binding b))))) 107 | (loop for binding in b2 108 | when (eq (name binding) x) 109 | do (return-from translate-slot-name (or (glsl-name binding) 110 | (%translate-name x))))) 111 | (%translate-name x))) 112 | 113 | #++ 114 | (defmethod translate-name ((x interface-binding)) 115 | (translate-name (binding x))) 116 | 117 | (defmethod translate-name ((x interface-stage-binding)) 118 | (translate-name (or (interface-block x) (binding x)))) 119 | 120 | (defmethod translate-name ((x generic-type)) 121 | (or (glsl-name x) (%translate-name (name (get-equiv-type x))))) 122 | 123 | (defmethod translate-name ((x array-type)) 124 | (translate-name (base-type x))) 125 | 126 | (defmethod translate-name ((x variable-read)) 127 | (translate-name (binding x))) 128 | 129 | 130 | (defmethod translate-type (type) 131 | (string type) 132 | #++(error "don't know how to compile type ~s" type)) 133 | 134 | (defmethod translate-type ((type any-type)) 135 | ;; fixme: just for debugging, should be an error once things are working properly 136 | "T") 137 | 138 | (defmethod translate-type ((type ref-type)) 139 | (translate-type (get-equiv-type type))) 140 | 141 | (defmethod translate-type ((type concrete-type)) 142 | (glsl-name type)) 143 | 144 | (defmethod translate-type ((type constrained-type)) 145 | (let ((types)) 146 | (maphash (lambda (k v) (when v (push k types))) (types type)) 147 | (if (= 1 (length types)) 148 | (translate-name (car types)) 149 | (mapcar #'translate-name types)))) 150 | 151 | (defmethod translate-type ((type generic-type)) 152 | (let ((e (get-equiv-type type))) 153 | (if (eq type e) 154 | (string type) ;;? 155 | (translate-type e)))) 156 | 157 | (defmethod translate-type ((type array-type)) 158 | (translate-type (base-type 159 | (or (and (boundp '*binding-types*) 160 | (gethash type *binding-types*)) 161 | (value-type type))))) 162 | 163 | (defmethod translate-type ((type struct-type)) 164 | (or (glsl-name type) (%translate-name (name type)))) 165 | 166 | 167 | 168 | (defmacro assert-statement () 169 | `(when *in-expression* 170 | (with-standard-io-syntax 171 | (error "trying to print statement in expression context")))) 172 | 173 | #++(set-pprint-dispatch 'symbol 174 | (lambda (s o) 175 | (format s "~a" (translate-name o))) 176 | 0 177 | *pprint-glsl*) 178 | (defmethod %print ((o symbol) s) 179 | (format s "~a" (translate-name o))) 180 | 181 | (set-pprint-dispatch 'double-float 182 | (lambda (s o) 183 | (let ((*read-default-float-format* 'double-float)) 184 | ;; fixme: how should these be printed? 185 | (format s "~f" o))) 186 | 0 187 | *pprint-glsl*) 188 | 189 | 190 | ;; print uny cons without a higher-priority printer as a normal function call 191 | #++ 192 | (set-pprint-dispatch 'cons 193 | (lambda (s o) 194 | (let ((*in-expression* t)) 195 | (format s "~a~<(~;~@{~:_~a~#[~:;, ~]~}~;)~:>" (car o) (cdr o)))) 196 | 0 197 | *pprint-glsl*) 198 | 199 | ;;; printers for calls to "internal-function" variants 200 | (defparameter *internal-function-printers* (make-hash-table)) 201 | 202 | (defmacro defprinti ((form &rest args) (&optional (call (gensym))) &body body) 203 | (alexandria:with-gensyms (stream object) 204 | `(setf (gethash ',form *internal-function-printers*) 205 | (lambda (,stream ,object &key ((:call ,call) nil)) 206 | (declare (ignorable ,call)) 207 | ;; OBJECT is a FUNCTION-CALL instance, (called-function object) 208 | ;; should be a INTERNAL-FUNCTION, with NAME eq FORM 209 | (let ((*standard-output* ,stream)) 210 | (destructuring-bind (,@args) ,object 211 | ,@body)))) 212 | #++`(set-pprint-dispatch 213 | '(cons (member ,form)) 214 | (lambda (,stream ,object) 215 | (let ((*standard-output* ,stream)) 216 | (destructuring-bind (,@args) (cdr ,object) 217 | ,@body))) 218 | 1 *pprint-glsl*))) 219 | 220 | 221 | (defmacro defprint-binop (op c-op 0-arg 1-arg) 222 | `(defprinti (,op &rest args) () 223 | (let ((*in-expression* t)) 224 | (case (length args) 225 | (0 ,(or 0-arg `(error ,(format nil "no arguments to ~a ?" op)))) 226 | (1 ,(or 227 | (if (eq 1-arg t) 228 | `(format t "~a" (car args)) 229 | 1-arg) 230 | `(format t ,(format nil "(~a~~a)" c-op) (car args)))) 231 | (t (format t ,(format nil "(~~{~~a~~^ ~~#[~~:;~a ~~]~~})" c-op) args)))))) 232 | 233 | ;;; fixme: probably shouldn't be allowing 0/1 arg versions of these that 234 | ;;; use some specific number, since it should have been accounted for 235 | ;;; before type inference? 236 | (defprint-binop - "-" nil nil) 237 | (defprint-binop + "+" 0.0 t) 238 | (defprint-binop * "*" 1.0 t) 239 | (defprint-binop / "/" 1.0 (format t "(1.0 / ~a)" (car args))) 240 | (defprint-binop or "||" 0 t) 241 | (defprint-binop and "&&" 1 t) ;; should this be #xffffffff instead of 1 for t? 242 | (defprint-binop 3bgl-glsl:^^ "^^" 0 t) 243 | (defprint-binop logior "|" 0 t) 244 | (defprint-binop logand "&" #xffffffff t) ;; fixme: how many bits is -1? 245 | (defprint-binop logxor "^" 0 t) 246 | 247 | 248 | 249 | (defprinti (1- x) () 250 | (let ((*in-expression* t)) 251 | (format t "~a" `(,x - 1)))) 252 | (defprinti (1+ x) () 253 | (let ((*in-expression* t)) 254 | (format t "~a" `(,x + 1)))) 255 | (defprinti (not x) () 256 | (let ((*in-expression* t)) 257 | (format t "~a" `(! ,x)))) 258 | 259 | (defprinti (3bgl-glsl::incf x &optional y) () 260 | (let ((*in-expression* t)) 261 | (if y 262 | (format t "(~a+=~a)" x y) 263 | (format t "(~a++)" x)))) 264 | (defprinti (3bgl-glsl::decf x &optional y) () 265 | (let ((*in-expression* t)) 266 | (if y 267 | (format t "(~a-=~a)" x y) 268 | (format t "(~a--)" x)))) 269 | 270 | (defprinti (3bgl-glsl::++ x) () 271 | (let ((*in-expression* t)) 272 | (format t "(++~a)" x))) 273 | (defprinti (3bgl-glsl::-- x) () 274 | (let ((*in-expression* t)) 275 | (format t "(--~a)" x))) 276 | 277 | (defmethod integral-type ((type concrete-type)) 278 | (and (scalar/vector-set type) 279 | (member (name (aref (scalar/vector-set type) 1)) 280 | '(:int :uint)))) 281 | 282 | (defmethod integral-type ((type constrained-type)) 283 | (some #'integral-type (alexandria:hash-table-keys (types type)))) 284 | 285 | (defprinti (mod a b) (call) 286 | (let ((*in-expression* t) 287 | (type (gethash call *binding-types*))) 288 | #++(with-standard-io-syntax 289 | (break "mod" a b call *binding-types*)) 290 | (with-standard-io-syntax 291 | (assert type)) 292 | (if (integral-type (first type)) 293 | (format t "(~a % ~a)" a b) 294 | (format t "mod(~a, ~a)" a b)))) 295 | 296 | 297 | ;; only handling binary versions of compare ops for now, 298 | ;; can expand multi arg versions in earlier pass if needed 299 | (macrolet ((compares (&rest ops) 300 | `(progn 301 | ,@(loop for (op c-op) in ops 302 | collect `(defprinti (,op a b) () 303 | (let ((*in-expression* t)) 304 | (format t ,(format nil"(~~a ~a ~~a)" c-op) 305 | a b))))))) 306 | (compares (= "==") 307 | (/= "!=") 308 | (< "<") 309 | (> ">") 310 | (<= "<=") 311 | (>= ">="))) 312 | 313 | (defprinti (zerop x) (call) 314 | (let ((*in-expression* t) 315 | (type (gethash call *binding-types*))) 316 | (with-standard-io-syntax 317 | (assert type)) 318 | (if (integral-type (second type)) 319 | (format t "(0 == ~a)" x) 320 | (format t "(0.0 == ~a)" x)))) 321 | 322 | (defprinti (ash i c) () 323 | (cond 324 | ((numberp c) 325 | (let ((*in-expression* t)) 326 | (format t "(~a ~a ~a)" i (if (plusp c) "<<" ">>") (abs c)))) 327 | (t (error "tried to print ASH with non-constant shift?")))) 328 | 329 | (defprinti (3bgl-glsl::<< i c) () 330 | (let ((*in-expression* t)) 331 | (format t "(~a << ~a)" i c))) 332 | 333 | (defprinti (3bgl-glsl::>> i c) () 334 | (let ((*in-expression* t)) 335 | (format t "(~a >> ~a)" i c))) 336 | 337 | (defprinti (return x) () 338 | (assert-statement) 339 | (let ((*in-expression* t)) 340 | (format t "return ~a" x))) 341 | 342 | (defprinti (values &optional x) () 343 | (when x 344 | (let ((*in-expression* t)) 345 | (format t "~a" x)))) 346 | 347 | (defprinti (3bgl-glsl:discard) () 348 | (assert-statement) 349 | (format t "discard")) 350 | 351 | 352 | (defmacro defprint (type (object) &body body) 353 | (alexandria:with-gensyms (stream) 354 | `(progn 355 | (defmethod %print ((,object ,type) *standard-output*) 356 | ,@body) 357 | (set-pprint-dispatch 358 | ',type 359 | (lambda (,stream ,object) 360 | (%print ,object ,stream)) 361 | 1 *pprint-glsl*)))) 362 | 363 | (defun vector->{} (x) 364 | (typecase x 365 | (array-initialization 366 | (with-output-to-string (s) 367 | (with-standard-io-syntax (break "foo1" x)) 368 | (format s "{") 369 | (loop for (a more) on (arguments x) 370 | do (%print a s) 371 | when more do (format s ", ")) 372 | (format s "}"))) 373 | (vector 374 | (with-output-to-string (s) 375 | (with-standard-io-syntax (break "foo2" x)) 376 | (format s "{") 377 | (loop for a across x 378 | for i from 0 379 | do (%print a s) 380 | while (< i (length x)) 381 | do (format s ", ")) 382 | (format s "}")) 383 | ) 384 | (t x))) 385 | 386 | (defprint array-initialization (o) 387 | (format t "{~{~a~^, ~}}" (arguments o)) 388 | #++(format t "(~{~a~^, ~})" (arguments o))) 389 | 390 | (defparameter *interface-qualifier-order* 391 | ;; ordering is relaxed in 4.2, but still need to get centroid before 392 | ;; in/out as well, so might as well sort anyway 393 | (alexandria:plist-hash-table 394 | '(:precise 1 395 | :invariant 2 396 | :smooth 5 :flat 5 :noperspective 5 ;; interpolation 397 | :no-perspective 5 398 | ;; 4.x, unspecified order, so just picking one... 399 | :coherent 7 :volatile 7 :restrict 7 :readonly 7 :writeonly 7 400 | :read-only 7 :write-only 7 401 | ;; centroid etc immediately before in/out (part of storage qual in spec) 402 | :centroid 9 :patch 9 :sample 9 403 | :in 10 :const 10 :out 10 :attribute 10 :uniform 10 ;; storage qualifier 404 | :buffer 10 :shared 10 405 | :varying 10 ;; deprecated 406 | :lowp 15 :mediump 15 :highp 15 ;; precision 407 | ))) 408 | 409 | (defun sort-interface-qualifiers (q) 410 | (flet ((c (a b) 411 | ;; possibly should default to something for unknown 412 | ;; qualifiers, but probably would be wrong so just error 413 | ;; here 414 | (< (gethash a *interface-qualifier-order*) 415 | (gethash b *interface-qualifier-order*)))) 416 | (sort (copy-list (alexandria:ensure-list q)) #'c))) 417 | 418 | (defun translate-interface-qualifiers (q) 419 | (flet ((tx (n) 420 | (string-downcase (remove #\- (symbol-name n))))) 421 | (mapcar #'tx (sort-interface-qualifiers q)))) 422 | 423 | 424 | (defprint initialized-binding (o) 425 | (assert-statement) 426 | (let ((*in-expression* t)) 427 | (if (typep (value-type o) 'array-type) 428 | (format t "~{~(~a ~)~}~@[~a ~]~a[~a]~@[ = ~a~]" 429 | ;; might need type for literal initializers? if so, figure 430 | ;; out how to distinguish them... 431 | #++"~{~(~a ~)~}~@[~a ~]~a[~a]~@[ = ~3:*~a[]~2*~a~]" 432 | (translate-interface-qualifiers (qualifiers o)) 433 | (translate-type (base-type 434 | (or (and (boundp '*binding-types*) 435 | (gethash o *binding-types*)) 436 | (value-type o)))) 437 | (translate-name o) 438 | (array-size (value-type o)) 439 | (initial-value-form o)) 440 | (format t "~{~(~a ~)~}~@[~a ~]~a~@[ = ~a~]" 441 | (translate-interface-qualifiers (qualifiers o)) 442 | (translate-type (or (and (boundp '*binding-types*) 443 | (gethash o *binding-types*)) 444 | (value-type o))) 445 | (translate-name o) 446 | (initial-value-form o))))) 447 | 448 | (defprint binding (o) 449 | (assert-statement) 450 | (let ((*in-expression* t)) 451 | (format t "~{~a ~}~@[~a ~]~a~@[~a~]" 452 | (translate-interface-qualifiers (qualifiers o)) 453 | (translate-type (or (and (boundp '*binding-types*) 454 | (gethash o *binding-types*)) 455 | (value-type o))) 456 | (translate-name o) 457 | (array-suffix (or (and (boundp '*binding-types*) 458 | (gethash o *binding-types*)) 459 | (value-type o)))))) 460 | 461 | (defprint slot-access (o) 462 | (format t "~a" (translate-name o))) 463 | 464 | (defprint swizzle-access (o) 465 | (format t "~a" (translate-name o))) 466 | 467 | (defprint array-access (o) 468 | (format t "~a" (translate-name o))) 469 | 470 | (defun print-main-layout-qualifiers (q) 471 | (maphash (lambda (k v) 472 | (format t "layout(~{~@[~a=~]~@[~a~^,~]~}) ~a;~%" 473 | (loop for (a b) on v by #'cddr 474 | ;; allow nil -> X or X -> X 475 | ;; to mean single element without = 476 | for single = (or (not a) (eq a b)) 477 | collect (unless single 478 | (%translate-name a :lc-underscore t)) 479 | collect (if (and single b) 480 | (%translate-name b :lc-underscore t) 481 | b)) 482 | (translate-name k))) 483 | q)) 484 | 485 | (defprint global-function (o) 486 | (assert-statement) 487 | ;; fixme: clean this layout stuff up... 488 | ;; if function is "main", check for extra layout qualifiers 489 | (when (and (string= (translate-name o) "main") (layout-qualifiers o) 490 | ;; compute layout qualifiers need printed earlier so 491 | ;; other functions can use gl_WorkGroupSize etc 492 | (not (eql *current-shader-stage* :compute))) 493 | (print-main-layout-qualifiers (layout-qualifiers o))) 494 | 495 | ;; print function def 496 | (format t "~a ~a ~<(~;~@{~:_~a~#[~:;, ~]~}~;)~:> {~%" 497 | (or (translate-type (or (gethash :return *binding-types*) 498 | (value-type o))) "void") 499 | (translate-name o) 500 | (bindings o)) 501 | (call-next-method) 502 | (format t "~&}~%")) 503 | 504 | (defprint function-call (o) 505 | (let ((f (called-function o)) 506 | (args (arguments o))) 507 | (typecase f 508 | (internal-function 509 | (funcall (gethash (name f) *internal-function-printers* 510 | (lambda (s args &key &allow-other-keys) 511 | (let ((*in-expression* t)) 512 | (format s "~a~<(~;~@{~:_~a~#[~:;, ~]~}~;)~:>" 513 | (or (translate-name f) (name f)) 514 | args)))) 515 | *standard-output* args :call o)) 516 | (t 517 | (let ((*in-expression* t)) 518 | (format t "~a~<(~;~@{~:_~a~#[~:;, ~]~}~;)~:>" 519 | (translate-name f) args)))))) 520 | 521 | 522 | (defprint progn-body (o) 523 | (if *in-expression* 524 | (format t "~<(~;~@{~a~^,~})~:>" (body o)) 525 | (format t "~{~a~^;~%~}" (body o)))) 526 | 527 | (defprint implicit-progn (o) 528 | (if *in-expression* 529 | (call-next-method) 530 | (format t "~< ~@;~@{~a;~^~%~}~:>" (body o)))) 531 | 532 | (defprint binding-scope (o) 533 | (with-standard-io-syntax (assert-statement)) 534 | ;; fixme: avoid extra {} in LET at top level of a function 535 | ;; (bind a special when inside LET scope, clear it inside scopes 536 | ;; that add a binding scope (like FOR, DEFUN, etc?)) 537 | (let ((shadowed nil)) 538 | (loop for binding in (bindings o) 539 | for glsl = (translate-name binding) 540 | for old = (gethash glsl *live-variables*) 541 | do (if old 542 | (push (cons glsl old) shadowed) 543 | (push (cons glsl nil) shadowed)) 544 | (setf (gethash glsl *live-variables*) 545 | binding)) 546 | (format t "{~%~< ~@;~@{~a;~^~%~}~:>~%" (bindings o)) 547 | (call-next-method) 548 | (loop for (g . l) in shadowed 549 | do (if l 550 | (setf (gethash g *live-variables*) l) 551 | (remhash g *live-variables*)))) 552 | (format t "~&}")) 553 | 554 | (defprint variable-read (o) 555 | (format t "~a" (translate-name (binding o)))) 556 | 557 | (defprint variable-write (o) 558 | (if *in-expression* 559 | (let ((*in-expression* t)) 560 | (format t "(~a = ~a)" 561 | (translate-name (binding o)) 562 | (value o))) 563 | (let ((*in-expression* t)) 564 | (format t "~a = ~a" 565 | (translate-name (binding o)) 566 | (value o))))) 567 | 568 | (defprint if-form (o) 569 | (let ((cond (test-form o)) 570 | (then (then-form o)) 571 | (else (else-form o))) 572 | (if *in-expression* 573 | (format t "(~a?~a:~a)" cond then else) 574 | (progn 575 | (let ((*in-expression* t)) 576 | (format t "if (~a) {~%" cond)) 577 | (format t "~< ~@;~a;~:>" (list then)) 578 | (when else 579 | (format t "~&} else {~%") 580 | (format t "~< ~@;~a;~:>" (list else))) 581 | (format t "~&}"))))) 582 | 583 | (defprint for-loop (o) 584 | (let ((initialize (init-forms o)) 585 | (term (condition-forms o)) 586 | (step (step-forms o))) 587 | (if *in-expression* 588 | (error "can't expand 'for' loop in expression context") 589 | (progn 590 | (let ((*in-expression* t)) 591 | (format t "for (~{~a~^,~};~{~a~^,~};~{~a~^,~}) {~%" 592 | initialize term step)) 593 | (call-next-method) 594 | (format t "~&}"))))) 595 | 596 | (defprint struct-type (o) 597 | (format t "struct ~a {" (translate-name o)) 598 | (format t "~%~< ~@;~@{~a;~^~%~}~:>~%" (bindings o)) 599 | (format t "};~%")) 600 | 601 | 602 | (defmethod array-suffix (x) 603 | nil) 604 | 605 | (defmethod array-suffix ((x array-type)) 606 | (typecase (array-size x) 607 | (number (format nil "[~a]" (array-size x))) 608 | (null nil) 609 | ((or symbol binding) (format nil "[~a]" (translate-name (array-size x)))) 610 | (t "[]"))) 611 | 612 | (defmethod array-suffix ((x interface-binding)) 613 | (typecase (array-size x) 614 | (number (format nil "[~a]" (array-size x))) 615 | (null nil) 616 | (t "[]"))) 617 | 618 | (defmethod array-suffix ((x interface-stage-binding)) 619 | (typecase (array-size x) 620 | (number (format nil "[~a]" (array-size x))) 621 | (null nil) 622 | (t "[]"))) 623 | 624 | (defprint interface-binding (o) 625 | (let ((b (stage-binding o))) 626 | (format t "~@[layout(~(~{~@[~a = ~]~a~^,~}~)) ~]" 627 | (loop for (a b) on (layout-qualifier b) by #'cddr 628 | when b 629 | append (if (eq b t) 630 | ;; :X t -> x 631 | (list nil a) 632 | ;; NIL :X -> x 633 | ;; :x y -> x=y 634 | (list (and (not (eq a b)) a) 635 | b)))) 636 | (cond 637 | ((typep (binding b) 'struct-type) 638 | (format t "~{~a~^ ~} ~a ~a~@[~a~]" 639 | (translate-interface-qualifiers (interface-qualifier b)) 640 | (translate-name 641 | (name (or (interface-block b) (binding b)))) 642 | (translate-name o) 643 | (array-suffix (value-type b)))) 644 | ((or (interface-block b) (typep (binding b) 'bindings)) 645 | (format t "~{~a ~}~a {~%~< ~@;~@{~a;~^~%~}~:>~%}~@[ ~a~]~@[~a~]" 646 | (translate-interface-qualifiers (interface-qualifier b)) 647 | (translate-name b) 648 | (bindings (or (interface-block b) (binding b))) 649 | (unless (interface-block b) (translate-name o)) 650 | (array-suffix b))) 651 | (t 652 | (format t "~{~a~^ ~} ~a ~a~@[~a~]" 653 | (translate-interface-qualifiers (interface-qualifier b)) 654 | (translate-name (value-type b)) 655 | (translate-name o) 656 | (array-suffix (value-type b))))) 657 | (let ((d (default b))) 658 | (cond 659 | ((not d)) 660 | ((symbolp d) 661 | (format t " = ~a" (translate-name d))) 662 | (t 663 | (format t " = ~a" d)))) 664 | (format t ";~%"))) 665 | 666 | (defprint constant-binding (o) 667 | (call-next-method) 668 | (format t ";")) 669 | 670 | (defun pprint-glsl (form) 671 | (let* ((*print-pprint-dispatch* *pprint-glsl*) 672 | (*print-pretty* t) 673 | (*print-circle* nil) 674 | (old-debug *debugger-hook*) 675 | (*debugger-hook* (lambda (&rest r) 676 | (with-standard-io-syntax 677 | (apply old-debug r))))) 678 | (format t "~a~%" form))) 679 | -------------------------------------------------------------------------------- /spirv-test-shaders.lisp: -------------------------------------------------------------------------------- 1 | ;(delete-package '#:3bgl-shader-spirv-test-shaders) 2 | (defpackage #:3bgl-shader-spirv-test-shaders 3 | (:use #:3bgl-glsl/cl) 4 | (:export 5 | #:fragment)) 6 | (in-package #:3bgl-shader-spirv-test-shaders) 7 | 8 | 9 | (input in-color :uvec2 :stage :fragment) 10 | 11 | (output color :u64vec2 :stage :fragment) 12 | 13 | (uniform x :uint16 :stage :fragment) 14 | (input fv2 :vec2 :stage :fragment) 15 | (uniform f :float :stage :fragment) 16 | 17 | (defun fragment () 18 | (declare (values)) 19 | (memory-barrier) 20 | ;;(incf x) 21 | ;;(setf color (- in-color)) 22 | (setf fv2 (mod fv2 (vec2 1))) 23 | ) 24 | 25 | "#version 450 26 | uniform float x; 27 | 28 | in vec4 inColor; 29 | 30 | out vec4 color; 31 | 32 | void main () { 33 | color = inColor * x; 34 | } 35 | 36 | " 37 | -------------------------------------------------------------------------------- /spirv.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | 3 | (defvar *spirv-output*) 4 | (defvar *used-globals*) 5 | (defvar *current-arg-type* nil) 6 | (defmacro with-spirv-output (() &body body) 7 | `(let ((*spirv-output* nil) 8 | (*used-globals* nil)) 9 | ,@body)) 10 | 11 | (defun add-spirv (form) 12 | (push (print form) *spirv-output*)) 13 | (defun get-spirv () 14 | (nreverse *spirv-output*)) 15 | 16 | (defun add-global (form) 17 | (pushnew form *used-globals*)) 18 | (defun get-globals () 19 | (nreverse *used-globals*)) 20 | 21 | (defgeneric dump-spirv (object)) 22 | 23 | (defmethod dump-spirv (object) 24 | (cerror "continue" "dumping unknown object ~s (~s)?" object 25 | (list *current-call* *binding-types* 26 | (gethash *current-call* *binding-types*))) 27 | (format t "dumping unknown object ~s?~%" object) 28 | nil) 29 | 30 | (defmethod dump-spirv ((o interface-binding)) 31 | (let ((b (stage-binding o)) 32 | (interface) 33 | (decorations)) 34 | (loop with l = (alexandria:ensure-list (interface-qualifier b)) 35 | for i in '(:in :out :uniform :buffer) 36 | for s in '(3b-spirv/hl::input 37 | 3b-spirv/hl::output 38 | 3b-spirv/hl::uniform 39 | 3b-spirv/hl::buffer) 40 | when (member i l) 41 | do (when interface 42 | (error "multiple interfaces for object? ~s / ~s" o b)) 43 | (setf interface s)) 44 | 45 | (format t "~&interface binding:~%") 46 | (format t " name: ~s~%" (name o)) 47 | (format t " layout: ~s~%" (layout-qualifier b)) 48 | (format t " default: ~s~%" (default b)) 49 | (format t " interface: ~s~%" (interface-qualifier b)) 50 | (cond 51 | ((or (interface-block b) (typep (binding b) 'bindings)) 52 | (format t " (or interface-block bindings)~%") 53 | (format t " bindings: ~s~%" (bindings (or (interface-block b) 54 | (binding b)))) 55 | (format t " array-suffix: ~s~%" (array-size b))) 56 | (t 57 | (format t " !(or interface-block bindings)~%") 58 | (format t " type: ~s~%" (name (value-type b))) 59 | (format t " array-suffix: ~s~%" (when (typep (value-type b) 'array-type) 60 | (array-size (value-type b)))))) 61 | (let ((spv (list interface 62 | (or (glsl-name o) (name o)) 63 | (name (value-type b)) 64 | :default (default b)))) 65 | (format t "==~s~%" spv) 66 | (when (or (default b) (layout-qualifier b) 67 | (when (typep (value-type b) 'array-type) 68 | (array-size (value-type b)))) 69 | (break "todo" o)) 70 | (format t "~%") 71 | (add-spirv spv) 72 | nil))) 73 | 74 | (defmethod dump-spirv ((object constant-binding)) 75 | (break "dump" object)) 76 | 77 | (defun spv-tmp () 78 | (gensym "%")) 79 | 80 | (defmethod dump-spirv ((o variable-read)) 81 | (let* ((v (binding o)) 82 | (b (stage-binding v)) 83 | (bt (binding b)) 84 | (tmp (spv-tmp))) 85 | (add-spirv `(spirv-core:load ,tmp 86 | ,(name bt) 87 | ,(name v))) 88 | tmp)) 89 | 90 | (defun cast (x from to) 91 | (format t "~&!!!cast ~s: ~s -> ~s~%" 92 | x from to) 93 | ;; possibly should assert vectors have same size? 94 | (let ((tmp (spv-tmp))) 95 | (with-matcher m (from to) 96 | ;; int -> float = convert-s-to-f 97 | ;; uint -> float = convert-u-to-f 98 | ;; float -> float = f-convert 99 | ;; int/uint -> int/uint = [us]-convert 100 | ;; not sure if needed since no implicit casts? 101 | ;; float -> int/uint = convert-f-to-[su] 102 | (cond 103 | ((numberp from)) ;; don't (or at least shouldn't?) need to cast literals 104 | ((or (m signed floating) 105 | (m signed-vector floating-vector)) 106 | (add-spirv `(spirv-core:convert-s-to-f ,tmp ,to ,x))) 107 | ((or (m unsigned floating) 108 | (m unsigned-vector floating-vector)) 109 | (add-spirv `(spirv-core:convert-u-to-f ,tmp ,to ,x))) 110 | ((or (m floating floating) 111 | (m floating-vector floating-vector)) 112 | (add-spirv `(spirv-core:f-convert ,tmp ,to ,x))) 113 | ((or (m signed integral) 114 | (m signed-vector integral-vector)) 115 | (add-spirv `(spirv-core:s-convert ,tmp ,to ,x))) 116 | ((or (m unsigned integral) 117 | (m unsigned-vector integral-vector)) 118 | (add-spirv `(spirv-core:u-convert ,tmp ,to ,x))) 119 | (t (error "can't cast ~s to ~s?" from to)))) 120 | tmp)) 121 | 122 | (defmethod dump-spirv ((o variable-write)) 123 | (let ((tmp (dump-spirv (value o))) 124 | (from (if (typep (value o) 'function-call) 125 | (name (first (gethash (value o) *binding-types*))) 126 | (name (value-type (value o))))) 127 | (to (name (value-type (binding o))))) 128 | (unless (eq from to) 129 | (setf tmp (cast tmp from to))) 130 | (add-spirv `(spirv-core:store ,(name (binding (binding o))) ,tmp))) 131 | nil) 132 | 133 | (defmethod dump-spirv ((o global-function)) 134 | (let ((name (name o)) 135 | (ret (name (value-type o))) 136 | (body (body o)) 137 | (bindings (bindings o)) 138 | (binding-types (final-binding-type-cache o))) 139 | ;; not sure if returning arrays is valid? not handled yet if so... 140 | (assert (not (typep (value-type o) 'array-type))) 141 | (let ((body-spv (with-spirv-output () 142 | (map nil 'dump-spirv body) 143 | (get-spirv)))) 144 | (add-spirv 145 | `(defun ,name ,(mapcar 'name bindings) 146 | (declare (values ,ret) 147 | ,@(loop for b in bindings 148 | collect `(type ,(name (gethash b binding-types)) ,b))) 149 | ;; todo: local vars 150 | ,@body-spv)))) 151 | nil) 152 | 153 | (defmethod dump-spirv ((o number)) 154 | ;; just return a THE form as the name, and let assembler handle it 155 | ;; todo: add COERCE if needed 156 | `(the ,(name *current-arg-type*) ,o)) 157 | 158 | (defmethod dump-spirv ((o function-call)) 159 | (let* ((function-types (gethash o *binding-types*)) 160 | (args 161 | (loop for a in (arguments o) 162 | for *current-arg-type* in (cdr function-types) 163 | for vt = (etypecase a 164 | ((or number function-call) 165 | *current-arg-type*) 166 | (place (value-type a))) 167 | when (eq (name vt) (name *current-arg-type*)) 168 | collect (dump-spirv a) 169 | else 170 | collect (cast (dump-spirv a) 171 | (name vt) (name *current-arg-type*))))) 172 | (dump-spirv-call (called-function o) o args))) 173 | 174 | 175 | (defmethod generate-output (objects inferred-types 176 | (backend (eql :spirv)) 177 | &key &allow-other-keys) 178 | ;(break "spirv" shaken inferred-types) 179 | (with-spirv-output () 180 | (loop with dumped = (make-hash-table) 181 | for object in objects 182 | for stage-binding = (stage-binding object) 183 | for interface-block = (when stage-binding 184 | (interface-block stage-binding)) 185 | unless (and interface-block (gethash interface-block dumped)) 186 | do (etypecase object 187 | ((or generic-type interface-binding constant-binding) 188 | (dump-spirv object) 189 | (when interface-block 190 | (setf (gethash interface-block dumped) t))) 191 | (global-function 192 | (let ((overloads (gethash object inferred-types))) 193 | (assert overloads) 194 | (loop for overload in overloads 195 | for *binding-types* 196 | = (gethash overload 197 | (final-binding-type-cache 198 | object)) 199 | do (assert *binding-types*) 200 | (dump-spirv object)))))) 201 | ;; fixme: better way of communicating entry point name 202 | (let ((main (name *print-as-main*))) 203 | (print (list* 204 | ;; add GLSL boilerplate 205 | ;'(spirv-core:capability :todo) 206 | '(spirv-core:capability :shader) 207 | '(spirv-core:ext-inst-import :glsl "GLSL.std.450") 208 | '(spirv-core:memory-model :logical :glsl-450) 209 | `(spirv-core:entry-point ,*current-shader-stage* 210 | ,main ,main 211 | ,@(get-globals)) 212 | ;; todo: execution-mode declarations 213 | `(spirv-core:execution-mode ,main :origin-lower-left) 214 | ;; ? 215 | ;; `(spirv-core:source ?? 1) 216 | (get-spirv)))))) 217 | 218 | 219 | #++ 220 | (3bgl-shaders::generate-stage :fragment 'skybox-shaders::fragment :backend :spirv) 221 | 222 | #++ 223 | (3bgl-shaders::generate-stage :compute '3bgl-gpuanim-shaders::update-anim :backend :spirv) 224 | 225 | #++ 226 | (3b-spirv/hl::assemble-to-file 227 | "/tmp/3bgl-shader.spv" 228 | (3bgl-shaders::generate-stage :fragment '3bgl-shader-example-shaders::fragment :backend :spirv)) 229 | 230 | #++ 231 | (print 232 | (3b-spirv::disasm 233 | (3b-spirv/hl::assemble 234 | (3bgl-shaders::generate-stage :fragment 235 | '3bgl-shader-spirv-test-shaders::fragment 236 | :backend :spirv)))) 237 | #++ 238 | (3bgl-shaders::generate-stage :fragment 239 | '3bgl-shader-spirv-test-shaders::fragment 240 | :backend :spirv) 241 | -------------------------------------------------------------------------------- /todo.org: -------------------------------------------------------------------------------- 1 | * minimally usable/alpha 2 | ** DONE handle 'interface' declarations with mismatched types? 3 | CLOSED: [2014-08-24 Sun 03:30] 4 | for now just warning/error if a shader is ambiguous (uses a field 5 | with different types in different stages, and isn't declared for 6 | a specific stage) 7 | eventually may want to try type inference on all stages that have 8 | matching interface bindings? 9 | ** DONE handle ARRAY-ACCESS 10 | CLOSED: [2014-08-24 Sun 04:18] 11 | ** DONE fix type inference for (setf a (1+ (vec4 1 2 3 4))) 12 | CLOSED: [2014-08-24 Sun 12:51] 13 | infers a as ivec4, should be vec4 14 | (probably bad cast on write-variable) 15 | ** DONE make sure type inference works for places 16 | CLOSED: [2014-08-24 Sun 14:12] 17 | ** DONE fix expansion or printing of 1+ 18 | CLOSED: [2014-08-25 Mon 03:48] 19 | (1+ foo) -> (+ foo 1) should be (foo + 1) 20 | ** DONE add/update built-in variables/constants 21 | CLOSED: [2014-08-25 Mon 06:26] 22 | https://www.opengl.org/registry/doc/GLSLangSpec.4.50.diff.pdf#page=123 23 | ** DONE decide if RETURN should be required for return values from functions? 24 | CLOSED: [2014-08-25 Mon 12:52] 25 | -- requiring it for now... 26 | not sure if that is better or requiring (values) or declaration for 27 | void return? 28 | ** DONE rewrite finalization stuff to do full inference pass 29 | CLOSED: [2014-08-28 Thu 14:57] 30 | ** DONE clean up debug noise/commented junk, reformat code 31 | CLOSED: [2014-08-28 Thu 16:56] 32 | ** DONE make sure var initialization uses correct bindings whem vars are shadowed 33 | CLOSED: [2014-08-29 Fri 15:53] 34 | internally they refer to correct bindings, but if they have same name they 35 | might be wrong when printed 36 | ex: 37 | (let ((a 1)) 38 | (let ((a 2) 39 | (b a)) 40 | b ;; should be 1 41 | )) 42 | ** DONE make sure type declarations are used correctly 43 | CLOSED: [2014-08-30 Sat 13:05] 44 | particularly function return 45 | ** DONE handle (values) as 'void' 46 | CLOSED: [2014-08-30 Sat 13:05] 47 | ** DONE figure out why inference work grows with repeated C-c C-c 48 | CLOSED: [2014-09-04 Thu 23:12] 49 | ** DONE track function dependencies with glsl:defun macro 50 | CLOSED: [2014-09-10 Wed 21:17] 51 | ** DONE hook to call with list of modified functions when function is recompiled 52 | CLOSED: [2014-09-10 Wed 21:17] 53 | pass list of function name + names of all functions that depend on it? 54 | - only on successful compile 55 | (if possible, figure out how to avoid multiple calls from C-c C-k?) 56 | program using shaders could check for names of any active shaders, 57 | and try to finalize them for upload to card 58 | ** DONE track dependencies on types/constants/uniforms/varyings, call modified hook 59 | ** DONE pass to recompile dependents as needed 60 | ** DONE update constants when redefined 61 | ** DONE ? figure out how to avoid errors when reloading shaders with C-c C-l or C-c C-k 62 | 'next frame' isn't enough delay, since compiling whole file might 63 | take more than a frame 64 | lock might be enough to avoid errors, but still get some redundant compiles 65 | ** DONE handle dependencies between initialization of globals 66 | ex (defconstant +foo+ (* +bar+ 2)) 67 | ** DONE split out into separate repo 68 | ** DONE rename 'glsl' package to longer name 69 | ** DONE name stages :VERTEX-SHADER etc instead of :VERTEX, to match gl:create-shader? 70 | ** DONE documentation 71 | CLOSED: [2014-09-12 Fri 04:01] 72 | *** usage (host) 73 | **** updating programs/modified hook 74 | *** usage (glsl) 75 | **** defining package using glsl 76 | **** input/uniform/interface/output 77 | **** optional type declarations 78 | *** stuff that might change 79 | **** type names :vec3 etc to glsl:vec3? 80 | *** status/notes/warnings 81 | **** branches of IF have to unify? 82 | **** bad errors 83 | ** DONE fix names of glsl functions with 1D, 2D, 3D 84 | CLOSED: [2014-09-12 Fri 05:28] 85 | proofread names in general, emit-stream-vertex etc 86 | ** DONE check exports 87 | CLOSED: [2014-09-13 Sat 06:46] 88 | ** handle return type of IF better 89 | *** don't try to unify types if return type isn't used 90 | probably add an ':ignored' or ':unused-return' keyword to WALK and 91 | pass it as needed (all but last form in progn, all forms in global 92 | function, all forms in progn with that flag set) 93 | *** if return value is used, return a type with casts from both branches 94 | instead of unifying branches directly 95 | ** DONE cleanup/remove/update examples, add new examples 96 | CLOSED: [2014-09-13 Sat 08:13] 97 | ** DONE not getting dependencies right inside swizzle, possibly other places? 98 | CLOSED: [2015-01-04 Sun 19:59] 99 | ex uniform named UV, only accessed as (.xy uv) 100 | ** DONE handle dependencies between types better 101 | CLOSED: [2015-01-04 Sun 20:43] 102 | ex SSBO using a struct type 103 | ** DONE handle dependencies between types and constants 104 | CLOSED: [2017-06-03 Sat 23:38] 105 | ex constant used as length of array in a struct 106 | ** document struct stuff 107 | ** recompile functions when a type changes? 108 | ** DONE use reinitialize-instance when redefining structs 109 | CLOSED: [2015-01-04 Sun 20:43] 110 | ** clear bindings-used-by of interface-binding on redefinition 111 | ** fix type inference of optional args? 112 | ex (return) 113 | ** fix type inference of uninitialized LET bindings 114 | ex 115 | (let ((translation)) 116 | (setf translation 1.0)) 117 | also 118 | (let ((a)) (incf a (vec3 1 2 3))) with original INCF definition 119 | ** allow (let (foo) ...) syntax for uninitialized binding 120 | * 'beta' 121 | ** assign priorities to constraints, process worklist in priority order? 122 | priority of type = 1+ highest priority of constraint with that type as 'output' or 0 123 | priority of constraint = 1+ highest priority of 'input' types? 124 | ** api for getting info about uniforms/attributes/outputs of a shader 125 | ** better errors/warnings 126 | *** should be able to resolve a static type for 0-arity functions? 127 | *** error/warning for any constraints that can't be met 128 | *** track variable names etc in constraints for useful errors? 129 | *** misc specific errors 130 | **** VALUES declaration other than on a function/lambda 131 | ** add compiler macros for more complicated binops like =, <, etc 132 | = : (and (= a b) (= b c) ...) 133 | < : (and (< a b) (< b c) ...) 134 | /= : (and (/= a b) (/= a c) (/= b c) ...) 135 | ** add += etc operators? 136 | ** track types/changes/dependencies etc for global variables 137 | ** store cached static type assignments/overloads with function 138 | so we don't need to recalculate it every time 139 | (and clear when redefined/modified) 140 | ** fix package/namespace/environment stuff 141 | *** split out cl:foo and glsl:foo definitions (or combine them? 142 | *** split out definitions of glsl macros from host utils for defining them 143 | *** reorganize code 144 | ** DONE add somewhere to mark functions as vertex/fragment/etc only 145 | CLOSED: [2017-06-03 Sat 23:40] 146 | (declare (glsl:stage :vertex ...))? 147 | ** better handling for qualifiers for images (readonly, writeonly, etc) 148 | need to include in type so they can propagate from uniforms 149 | to function arguments, probably should veryify read/writeability 150 | in load/store 151 | ** add qualifiers to function arglists (declarations?) 152 | ex readonly/writeonly/etc for images 153 | ** figure out if optional arguments are working properly 154 | particularly during recompilation of existing shaders 155 | ** handle unused arguments better during type inference 156 | ** make sure -1 derives type int instead of uint? 157 | ** support some subset of CL array/vector types for declarations 158 | currently expects something like (:float 32) 159 | ** DONE figure out better way to handle package <-> environment association 160 | CLOSED: [2017-05-12 Fri 08:02] 161 | possibly should define things in an environment corresponding to 162 | symbol-package, or else require specifying an environment? 163 | ? alternately, require some explicit list of environments current 164 | package imports from, either from :use list in associated package, 165 | or explicit function linking them? 166 | - specific use case = defining things like (input color ...) and 167 | (input position ...) once and reusing it (where POSITION is 168 | probably CL:POSITION) 169 | - POSITION in particular will pretty commonly conflict, since it is in CL 170 | but not sure how often different things will want different definitions? 171 | (possibly a 2d lib would want vec2 or something would want ivec?) 172 | ** figure out multidimensional array syntax? 173 | ((:foo dim) dim)? 174 | (:foo (dim dim))? 175 | (:foo dim dim)? 176 | ** add more concrete types (int8, float16 etc) and aliases 177 | :int -> :int32 -> "int" instead of separate :int->"int"/:int32->"int" 178 | :mat2x2 -> :mat2 -> "mat2" instead of :mat2->"mat2",:mat2x2->"mat2x2"? 179 | *** types (including some aliases for existing types) 180 | uint8,16,32,64 181 | int8,16,32,64 182 | i8vec2,3,4 ui8vec2,3,4 183 | i16vec2,3,4 ui16vec2,3,4 184 | i32vec2,3,4 ui32vec2,3,4 185 | i64vec2,3,4 ui64vec2,3,4 186 | float16,32,64 187 | f16vec2,3,4 188 | f16mat2,3,4,NxM 189 | (possibly f32,64 versions of vec/mat?) 190 | ** possibly should move 1+,1- to macros? 191 | need to see how it goes through type inference, might need extra 192 | work to get correct type, and may end up extra instructions in 193 | spirv (for example if it loads constant integer, then casts to 194 | float instead of using a constant float) 195 | ** fix vector/mat constructors to allow extra elements in last argument 196 | ex: vec2(mat4) is allowed, but not vec2(mat4,scalar) etc 197 | ** check for conflicts between in/out and uniforms used in same shader stage 198 | probably needs to be after type inference 199 | * 'done' 200 | ** cache glsl from compiled shaders, add option to remove intermediate data 201 | for use in final release, don't need to retain all the type 202 | inference data if we don't plan to make any changes to shader, and 203 | don't want to waste time recompiling it every load 204 | ** decide how to represent struct accessors (just using @/slot-value for now) 205 | *** possibly .foo like swizzles? 206 | if so, possibly add some ability to merge struct accessors with swizzles 207 | so structs could have a RGB member, and type of .rgb would get extended 208 | to (or :vec34 :ivec34 ... that-struct-type) 209 | *** probably better to skip the . 210 | ** track glsl versions, add 4.1, maybe 3.x? 211 | ** in/out parameters? 212 | ** allow initialization of uniforms 213 | ** make sure we don't print different symbols with same glsl name? 214 | (at least for uniforms,functions and such with 'global' scope) 215 | can't really rename them during printing though, since we need to 216 | know the name of uniforms to set them from caller (and might have 217 | already generated programs with default name) 218 | probably error if detected, and add an option to prefix glsl names with 219 | package name and _ ? 220 | alternately, track name mapping along with shader compilation? 221 | might be OK, since we probably want to query locations for any 222 | that weren't statically allocated, and can just use static location 223 | instead of name for ones that were 224 | ** figure out/add rules for SETF stuff 225 | (setf (.rgb foo) ...) is ok, (setf (.rrr foo) ...) is bad, etc 226 | ** clean up/remove duplication between cl-walker and glsl-walker 227 | ** decide how to handle 'free' declarations 228 | (let ((a)) 229 | (let ((b)) 230 | (declare (:float a)) 231 | .. 232 | )) 233 | not sure if that should: 234 | a. be an error 235 | b. force A to be a float 236 | c. add a constraint that a can implicit-cast to float 237 | ** don't use reserved words as identifiers 238 | at a minimum, error, preferably rename 239 | * would be nice 240 | ** add better ways to distinguish mat/vec/scalar types and mat dimensions 241 | and refactor code to use them (spirv backend in particular) 242 | ** remove unused variables 243 | ** detect/remove dead code (after RETURN, etc) 244 | ** figure out if vec/mat constructors need a specific constraint type? 245 | mat4 with 10 args has to search through 5k or so types, though probabl 246 | pretty uncommon to pass 10 args to mat4 (usually 1,4,15,maybe 2 or 3) 247 | ** handle subroutine uniforms/subroutines in general? 248 | not sure how much change is needed 249 | need to figure out if subroutine uniforms have different namespace 250 | from normal ones? 251 | ** check for more places where :cast nil can be set for built-in functions 252 | also make sure the existing ones are right 253 | (either no cast allowed, or all types fully specified already) 254 | ** CSE/common subexpression optimizations? 255 | * spirv 256 | ** names of globals in output spv? 257 | ** add single-op / 258 | make a temp 1 of appropriate type and use normal / ? 259 | ** add single-op versions of +,*,AND,OR,etc 260 | ** see if (- 1) does right thing? 261 | not sure if it should return a signed int, or unsigned #xff..ff? 262 | also check negation of larger unsigned values 263 | ** check edge cases of constructor rules 264 | *** bool in int/float vec/mat should work 265 | *** construct vec from mat 266 | *** optimize mat/vec constructors that can use argument directly 267 | ex. vec4 from mat4, use component 0 directly 268 | or mat4 from vec4, store vec4 directly 269 | *** extra values passed to vec/mat constructors 270 | (last argument can have extras, but can't have extra arguments) 271 | ex: vec2(mat4) is allowed, but not vec2(mat4,scalar) etc 272 | ** spirv optimizers? 273 | *** add a composite-construct -> composite-extract optimizer? 274 | probably not common enough in real code to care, but things like 275 | (mat4 (mat3 x)) and similar construct the mat3 then extract the 276 | components to build the mat4. So could detect a 277 | composite-construct that is only used by composite-extract and 278 | use the original elements directly. 279 | 280 | *** possibly also composite-construct -> composite-construct for vec? 281 | ex (vec4 (vec2 a) (vec2 b)) -> (vec4 a a b b) 282 | *** CSE/redundant loads/stores etc 283 | need to figure out which loads can be dropped, probably at least 284 | locals and inputs? not worgroup shared mem, maybe not SSBO? 285 | *** 286 | -------------------------------------------------------------------------------- /utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:3bgl-shaders) 2 | 3 | ;;; newer attempt at 'nicer' interface, + helper for updating shaders 4 | 5 | ;; print shaders as compiled for debugging 6 | (defparameter *print-shaders* nil) 7 | 8 | (defparameter *default-recompilation-callback* nil) 9 | 10 | ;; this API's idea of what shader is currently active, so we know to 11 | ;; update uniforms directly (probably wrong if gl:use-shader is called 12 | ;; directly) 13 | (defparameter *bound-program* nil) 14 | 15 | (defclass shader-program () 16 | ((program :reader program :initform nil) 17 | ;; shader stage (as in gl:create-shader) -> name of function 18 | (stages :reader stages :initform (make-hash-table)) 19 | ;; name of function -> true/false 20 | (dirty :reader dirty :initform (make-hash-table)) 21 | ;; lisp name -> plist :glsl-name, :type, :dirty, :function, :value 22 | (uniforms :reader uniforms :initform (make-hash-table)) 23 | ;; lisp name -> lisp-name, "glsl-name", plist of :layout :components 24 | (ssbos :reader ssbos :initform (make-hash-table)) 25 | ;; lisp name -> lisp-name, "glsl-name", plist of :components 26 | (structs :reader structs :initform (make-hash-table)) 27 | ;; list of names of live uniforms for currently compiled program 28 | (live-uniforms :accessor live-uniforms :initform nil) 29 | ;; glsl name -> lisp name 30 | ;; (not sure if string or symbol should be primary way of 31 | ;; identifying a uniform, allowing both for now...) 32 | (name-map :reader name-map :initform (make-hash-table :test 'equal)) 33 | ;; target glsl version 34 | (version :accessor version :initform *default-version* :initarg :version) 35 | ;; list of functions to call after successful shader recompilation 36 | ;; shader object is passed as only argument 37 | (recompilation-callbacks :initform *default-recompilation-callback* 38 | :accessor recompilation-callbacks))) 39 | 40 | (defun flag-shader (shader-program function) 41 | ;; only flag it if in use, otherwise hash could accumulate lots of 42 | ;; junk in a program with lots of shaders 43 | (when (and shader-program 44 | (nth-value 1 (gethash function (dirty shader-program)))) 45 | (setf (gethash function (dirty shader-program)) t))) 46 | 47 | (defparameter *stage-name-map* 48 | (alexandria:plist-hash-table 49 | '(:vertex :vertex-shader 50 | :fragment :fragment-shader 51 | :geometry :geometry-shader 52 | :tess-control :tess-control-shader 53 | :tess-evaluation :tess-evaluation-shader 54 | :tess-eval :tess-evaluation-shader 55 | :compute :compute-shader 56 | ;; reverse mapping 57 | :vertex-shader :vertex 58 | :fragment-shader :fragment 59 | :geometry-shader :geometry 60 | :tess-control-shader :tess-control 61 | :tess-evaluation-shader :tess-eval 62 | :tess-evaluation-shader :tess-eval 63 | :compute-shader :compute))) 64 | 65 | ;; if bound, is called with shader object and list of shader functions 66 | ;; in shader-function, for programs that want to track active programs 67 | (defvar *shader-program-hook*) 68 | 69 | (defun shader-program (&rest r 70 | &key vertex fragment geometry 71 | tess-control tess-evaluation 72 | compute 73 | &allow-other-keys) 74 | (declare (ignore vertex fragment geometry 75 | tess-control tess-evaluation 76 | compute)) 77 | (let ((p (make-instance 'shader-program))) 78 | (loop for (%stage fun) on r by #'cddr 79 | for stage = (gethash %stage *stage-name-map* %stage) 80 | do (setf (gethash stage (stages p)) fun) 81 | (setf (gethash fun (dirty p)) t)) 82 | (when (boundp '*shader-program-hook*) 83 | (funcall *shader-program-hook* p (loop for (nil a) on r by #'cddr 84 | collect a))) 85 | p)) 86 | 87 | ;; generic interface to uniforms in program, uniform buffers, etc 88 | (defgeneric uniform (object &rest names-and-indices)) 89 | (defmethod uniform ((program shader-program) &rest names-and-indices) 90 | (assert (= 1 (length names-and-indices))) 91 | (let ((name (car names-and-indices))) 92 | (when (stringp name) 93 | (setf name (gethash name (name-map program)))) 94 | (getf (gethash name (uniforms program)) :value))) 95 | 96 | ;; method is (setf %uniform) so we can make a (setf uniform) that accepts 97 | ;; (values ...) 98 | ;; simple API, for scalars, vectors, single matrix 99 | ;; new-value should be a single value, or array stuitable to pass to uniform*fv 100 | (defmethod (setf %uniform) (new-value (program shader-program) &rest names-and-indices) 101 | (assert (= 1 (length names-and-indices))) 102 | (let ((name (car names-and-indices))) 103 | (when (stringp name) 104 | (setf name (gethash name (name-map program)))) 105 | (setf (getf (gethash name (uniforms program)) :dirty) t) 106 | (when name 107 | (when (consp new-value) 108 | (setf new-value (coerce new-value 'vector))) 109 | (setf (getf (gethash name (uniforms program)) :value) new-value)) 110 | (when (eq *bound-program* program) 111 | (let* ((u (gethash name (uniforms program))) 112 | (i (getf u :index)) 113 | (f (getf u :function))) 114 | (when (and i f) 115 | (funcall f i new-value))) 116 | ) 117 | new-value)) 118 | 119 | ;; to be replaced with better version... 120 | (defun (setf uniform) (new-value program &rest names-and-indices) 121 | (apply #'(setf %uniform) new-value program names-and-indices)) 122 | 123 | ;; duplicated from cl-opengl so we can change default of TRANSPOSE arg :/ 124 | (macrolet ((def (n % comp) 125 | `(defun ,n (location matrices &optional (transpose nil)) 126 | (assert (or (typep (aref matrices 0) 'number) 127 | (typep (aref matrices 0) 'array))) 128 | #+sbcl 129 | (when (typep matrices '(simple-array single-float (,comp))) 130 | (sb-sys:with-pinned-objects (matrices) 131 | (return-from ,n 132 | (,% location 1 transpose 133 | (sb-sys:vector-sap matrices))))) 134 | #+ccl 135 | (when (typep matrices '(simple-array single-float (,comp))) 136 | ;; we need to be a bit more careful with CCL, since 137 | ;; CCL:WITH-POINTER-TO-IVECTOR inhibits GC, so we 138 | ;; try to avoid signalling an error inside it 139 | (handler-case 140 | (ccl:with-pointer-to-ivector (p matrices) 141 | (return-from ,n 142 | (,% location 1 transpose p))) 143 | ;; resignal any errors outside the 'no GC' scope 144 | (error (e) (error e)))) 145 | (let* ((matrices (if (typep (aref matrices 0) 'vector) 146 | matrices 147 | (vector matrices))) 148 | (matrix-count (length matrices))) 149 | (cffi:with-foreign-object (array '%gl:float 150 | (* matrix-count ,comp)) 151 | (loop for matrix across matrices 152 | for i from 0 153 | do (when (typep matrix '(simple-array single-float 154 | (,comp))) 155 | (loop for j below ,comp 156 | do (setf (cffi:mem-aref array '%gl:float 157 | (+ j (* i ,comp))) 158 | (row-major-aref matrix j))) 159 | (loop for j below ,comp 160 | do (setf (cffi:mem-aref array '%gl:float 161 | (+ j (* i ,comp))) 162 | (float (row-major-aref matrix j) 163 | 1.0))))) 164 | (,% location matrix-count transpose array))))) 165 | (d (&rest defs) 166 | `(progn 167 | ,@(loop for def in defs collect `(def ,@def))))) 168 | (d (uniform-matrix-2fv %gl:uniform-matrix-2fv 4) 169 | (uniform-matrix-2x3-fv %gl:uniform-matrix-2x3-fv 6) 170 | (uniform-matrix-2x4-fv %gl:uniform-matrix-2x4-fv 8) 171 | 172 | (uniform-matrix-3x2-fv %gl:uniform-matrix-3x2-fv 6) 173 | (uniform-matrix-3fv %gl:uniform-matrix-3fv 9) 174 | (uniform-matrix-3x4-fv %gl:uniform-matrix-3x4-fv 12) 175 | 176 | (uniform-matrix-4x2-fv %gl:uniform-matrix-4x2-fv 8) 177 | (uniform-matrix-4x3-fv %gl:uniform-matrix-4x3-fv 12) 178 | (uniform-matrix-4fv %gl:uniform-matrix-4fv 16) 179 | )) 180 | 181 | (defun reset-program (shader-program) 182 | (when (program shader-program) 183 | (gl:delete-program (shiftf (slot-value shader-program 'program) nil))) 184 | (setf (live-uniforms shader-program) nil) 185 | (clrhash (uniforms shader-program)) 186 | (clrhash (dirty shader-program))) 187 | 188 | (defun %reload-program (shader-program) 189 | (let ((source nil) 190 | (shaders nil) 191 | (stages (alexandria:hash-table-alist (stages shader-program))) 192 | (program nil) 193 | (all-uniforms nil) 194 | (uniform-hash (make-hash-table)) 195 | (ssbo-hash (make-hash-table)) 196 | (struct-hash (make-hash-table)) 197 | (name-map (make-hash-table :test 'equal))) 198 | (setf source 199 | (loop for (%stage . name) in stages 200 | for stage = (gethash %stage *stage-name-map* %stage) 201 | for source = nil 202 | do (when *print-shaders* 203 | (format t "generating shader ~s @ ~s~%" name stage)) 204 | (multiple-value-bind (.source uniforms attributes 205 | ssbos structs) 206 | (3bgl-shaders::generate-stage 207 | stage name :version (version shader-program) 208 | :expand-uniforms t) 209 | (declare (ignore attributes)) 210 | (setf source .source) 211 | (setf all-uniforms (union all-uniforms uniforms :key 'car)) 212 | (loop for (l g type) in uniforms 213 | do (setf (getf (gethash l uniform-hash) :glsl-name) 214 | g) 215 | (setf (gethash g name-map) l) 216 | (setf 217 | (getf (gethash l uniform-hash) :function) 218 | (ecase type 219 | (:float '%gl:uniform-1f) 220 | (:vec2 #'gl:uniformfv) 221 | (:vec3 #'gl:uniformfv) 222 | (:vec4 #'gl:uniformfv) 223 | (:bool (lambda (l x) 224 | (if (numberp x) 225 | (%gl:uniform-1i l x) 226 | (if x 227 | (%gl:uniform-1i l 1) 228 | (%gl:uniform-1i l 0))))) 229 | (:int '%gl:uniform-1i) 230 | (:uint '%gl:uniform-1ui) 231 | (:ivec2 #'gl:uniformiv) 232 | (:ivec3 #'gl:uniformiv) 233 | (:ivec4 #'gl:uniformiv) 234 | (:mat2 #'uniform-matrix-2fv) 235 | (:mat2x3 #'uniform-matrix-2x3-fv) 236 | (:mat2x4 #'uniform-matrix-2x4-fv) 237 | (:mat3x2 #'uniform-matrix-3x2-fv) 238 | (:mat3 #'uniform-matrix-3fv) 239 | (:mat3x4 #'uniform-matrix-3x4-fv) 240 | (:mat4x2 #'uniform-matrix-4x2-fv) 241 | (:mat4x3 #'uniform-matrix-4x3-fv) 242 | (:mat4 #'uniform-matrix-4fv) 243 | (:sampler-1d #'gl:uniformi) 244 | (:sampler-2d #'gl:uniformi) 245 | (:sampler-3d #'gl:uniformi) 246 | (:sampler-cube #'gl:uniformi) 247 | (:sampler-2d-rect #'gl:uniformi) 248 | (:sampler-1d-array #'gl:uniformi) 249 | (:sampler-2d-array #'gl:uniformi) 250 | (:sampler-cube-array #'gl:uniformi) 251 | (:sampler-buffer #'gl:uniformi) 252 | (:sampler-2d-ms-array #'gl:uniformi) 253 | (:sampler-2d-ms #'gl:uniformi) 254 | (:sampler-1d-shadow #'gl:uniformi) 255 | (:sampler-2d-shadow #'gl:uniformi) 256 | (:sampler-cube-shadow #'gl:uniformi) 257 | (:sampler-2d-rect-shadow #'gl:uniformi) 258 | (:sampler-1d-array-shadow #'gl:uniformi) 259 | (:sampler-2d-array-shadow #'gl:uniformi) 260 | (:sampler-cube-array-shadow #'gl:uniformi) 261 | (:image-1d #'gl:uniformi) 262 | (:image-2d #'gl:uniformi) 263 | (:image-3d #'gl:uniformi) 264 | (:image-cube #'gl:uniformi) 265 | (:image-2d-rect #'gl:uniformi) 266 | (:image-1d-array #'gl:uniformi) 267 | (:image-2d-array #'gl:uniformi) 268 | (:image-cube-array #'gl:uniformi) 269 | (:image-2d-ms-array #'gl:uniformi) 270 | (:image-2d-ms #'gl:uniformi) 271 | 272 | (:atomic-uint 273 | ;; ignore atomic counter buffers for 274 | ;; now, since they behave differently... 275 | (lambda (&rest r) (declare (ignore r))))))) 276 | (loop for s in ssbos 277 | for n = (car s) 278 | do (setf (gethash n ssbo-hash) s)) 279 | (loop for s in structs 280 | for n = (car s) 281 | do (setf (gethash n struct-hash) s))) 282 | collect (list %stage source))) 283 | ;; assuming failed compile signalled an error so won't get here 284 | (unwind-protect 285 | (progn 286 | (setf program (gl:create-program)) 287 | (loop for (stage source) in source 288 | for shader = (gl:create-shader stage) 289 | do (push shader shaders) 290 | (when *print-shaders* 291 | (format t "~s~%" source)) 292 | (gl:shader-source shader source) 293 | (gl:compile-shader shader) 294 | (cond 295 | ((gl:get-shader shader :compile-status) 296 | (gl:attach-shader program shader)) 297 | (t 298 | ;; fixme: make error printing and stream configurable 299 | (unless *print-shaders* ;; already printed it 300 | (format t "~s~%" source)) 301 | (format t "~s shader compile failed: ~s" 302 | stage (gl:get-shader-info-log shader)) 303 | (return-from %reload-program nil)))) 304 | (gl:link-program program) 305 | (cond 306 | ((gl:get-program program :link-status) 307 | ;; if it linked, swap with old program so we delete that on uwp 308 | (rotatef program (slot-value shader-program 'program))) 309 | (t 310 | ;; fixme: make error printing and stream configurable 311 | (format t "program link failed: ~s" 312 | (gl:get-program-info-log program)) 313 | (return-from %reload-program nil))) 314 | ;; update shader-program object 315 | (setf (slot-value shader-program 'uniforms) uniform-hash) 316 | (setf (slot-value shader-program 'ssbos) ssbo-hash) 317 | (setf (slot-value shader-program 'structs) struct-hash) 318 | (setf (slot-value shader-program 'name-map) name-map) 319 | ;; update uniforms in program 320 | (setf (live-uniforms shader-program) nil) 321 | (when *print-shaders* 322 | (format t " uniforms = ~s~%" all-uniforms)) 323 | (loop for (name glsl-name) in all-uniforms 324 | for index = (gl:get-uniform-location (program shader-program) 325 | glsl-name) 326 | do (setf (getf (gethash name (uniforms shader-program)) 327 | :index) 328 | index) 329 | (pushnew name (live-uniforms shader-program))) 330 | (when *print-shaders* 331 | (format t " = ~s~%" (alexandria:hash-table-alist 332 | (uniforms shader-program)))) 333 | (maphash (lambda (k v) 334 | (declare (ignore v)) 335 | (setf (gethash k (dirty shader-program)) nil)) 336 | (dirty shader-program)) 337 | ;; recompile succeeded, call recompilation callback and return T 338 | (map nil (lambda (c) (funcall c shader-program)) 339 | (recompilation-callbacks shader-program)) 340 | t) 341 | ;; unwind-protect cleanup: delete any created shaders, delete 342 | ;; any program in PROGRAM (if compile/link was successul, it 343 | ;; will be previous program if any) 344 | (loop for s in shaders 345 | do (gl:delete-shader s)) 346 | (when program 347 | (gl:delete-program program))))) 348 | 349 | (defun ensure-compiled (program) 350 | (let ((dirty nil)) 351 | (alexandria:maphash-values (lambda (k) (setf dirty (or dirty k))) 352 | (dirty program)) 353 | (when (or dirty (not (program program))) 354 | (alexandria:maphash-keys (lambda (k) 355 | (setf (gethash k (dirty program)) nil)) 356 | (dirty program)) 357 | (%reload-program program) 358 | t))) 359 | 360 | 361 | (defmethod use-program ((program shader-program)) 362 | (ensure-compiled program) 363 | 364 | (when (program program) 365 | (gl:use-program (program program)) 366 | (loop for uniform-name in (live-uniforms program) 367 | for uniform = (gethash uniform-name (uniforms program)) 368 | for function = (getf uniform :function) 369 | for value = (getf uniform :value) 370 | for index = (getf uniform :index) 371 | when (and function value index) 372 | do (funcall function index value)) 373 | t)) 374 | 375 | (defmacro with-program ((program &key (error-p nil)) &body body) 376 | ;; not sure if iter is better to UNWIND-PROTECT and risk errors in 377 | ;; the cleanup or to risk not resetting program on NLX... 378 | (alexandria:once-only (program) 379 | `(let ((*bound-program* (and (use-program ,program) ,program))) 380 | ,@(when error-p `((assert *bound-program*))) 381 | (prog1 382 | (progn ,@body) 383 | (gl:use-program 0))))) 384 | 385 | 386 | --------------------------------------------------------------------------------