summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-02-09 08:40:34 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commitb941edf4d95697e84b56f2702dab3b33aa22f60e (patch)
treeedd6982023e18456da99e5ba34b55c7dafa831c7
parent1fb1330efe171fd7ecbb94f901a3c43592b0a2d5 (diff)
Messy but working shader linker.
-rw-r--r--chickadee/graphics/seagull.scm291
1 files changed, 271 insertions, 20 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index a1adb1d..ec600ba 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -43,8 +43,22 @@
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
- #:export (compile-seagull))
+ #:export (compile-seagull-module
+ define-vertex-shader
+ define-fragment-shader
+ seagull-module?
+ seagull-module-vertex?
+ seagull-module-fragment?
+ seagull-module-stage
+ seagull-module-inputs
+ seagull-module-outputs
+ seagull-module-uniforms
+ seagull-module-source
+ seagull-module-compiled
+ seagull-module-global-map
+ link-seagull-modules))
;; The Seagull compiler is designed as a series of source-to-source
;; program transformations in which each transformation pass results
@@ -52,7 +66,6 @@
;; GLSL code.
;; TODO:
-;; - Array types
;; - Loops
;; - Shader stage linking
;; - Input/uniform mapping for invoking shaders from Scheme
@@ -419,12 +432,14 @@
`(call ,(expand operator stage env) ,@(expand:list operands stage env)))
(define (expand:top-level qualifiers types names body stage env)
- (let* ((env* (compose-envs (alpha-convert names) env)))
+ (let* ((global-map (alpha-convert names))
+ (env* (compose-envs global-map env)))
;; TODO: Support interpolation qualifiers.
- `(top-level ,(map (lambda (qualifier type name)
- (list qualifier type (lookup name env*)))
- qualifiers types names)
- ,(expand body stage env*))))
+ (values `(top-level ,(map (lambda (qualifier type name)
+ (list qualifier type (lookup name env*)))
+ qualifiers types names)
+ ,(expand body stage env*))
+ global-map)))
(define (expand:outputs names exps stage env)
`(outputs
@@ -2151,6 +2166,13 @@
(list (cons struct-var struct)
(cons field-var field-type)))))
structs))
+ (('struct-field struct-var field field-var)
+ (filter-map (lambda (struct)
+ (let ((field-type (struct-type-ref struct field)))
+ (and field-type
+ (list (cons struct-var struct)
+ (cons field-var field-type)))))
+ structs))
(('or preds ...)
(concatenate (map (lambda (pred)
(possible-substitutions pred structs))
@@ -2220,7 +2242,11 @@
(define (type-descriptor->glsl desc)
(match desc
((? symbol?)
- desc)
+ (match (type-descriptor->type desc)
+ ((? primitive-type? primitive)
+ (primitive-type-name primitive))
+ ((? struct-type? struct)
+ (struct-type-name struct))))
(('array desc* length)
(format #f "~a[~a]"
(type-descriptor->glsl desc*)
@@ -2507,17 +2533,242 @@
;; Combine all of the compiler passes on a user provided program and
;; emit GLSL code if the program is valid.
-(use-modules (ice-9 pretty-print))
-
-(define* (compile-seagull exp #:key (stage 'vertex)
- (version '330)
- (port (current-output-port)))
+(define-record-type <shader-input>
+ (make-shader-input type name)
+ shader-input?
+ (type input-type)
+ (name input-name))
+
+(define-record-type <shader-output>
+ (make-shader-output type name)
+ shader-output?
+ (type output-type)
+ (name output-name))
+
+(define-record-type <shader-uniform>
+ (make-shader-uniform type name)
+ shader-uniform?
+ (type uniform-type)
+ (name uniform-name))
+
+(define-record-type <seagull-module>
+ (%make-seagull-module stage inputs outputs uniforms source compiled
+ global-map max-id)
+ seagull-module?
+ (stage seagull-module-stage)
+ (inputs seagull-module-inputs)
+ (outputs seagull-module-outputs)
+ (uniforms seagull-module-uniforms)
+ (source seagull-module-source)
+ (compiled seagull-module-compiled)
+ ;; Original name -> alpha converted name mapping for inputs,
+ ;; outputs, and uniforms.
+ (global-map seagull-module-global-map)
+ (max-id seagull-module-max-id))
+
+(define* (make-seagull-module #:key stage inputs outputs uniforms source
+ compiled global-map max-id)
+ (%make-seagull-module stage inputs outputs uniforms source compiled
+ global-map max-id))
+
+(define (seagull-module-vertex? module)
+ (eq? (seagull-module-stage module) 'vertex))
+
+(define (seagull-module-fragment? module)
+ (eq? (seagull-module-stage module) 'fragment))
+
+(define* (compile-seagull-module #:key stage source
+ (inputs '()) (outputs '()) (uniforms '()))
+ (unless (memq stage '(vertex fragment))
+ (error "invalid shader stage" stage))
(parameterize ((unique-identifier-counter 0)
(unique-variable-type-counter 0))
- (let* ((expanded (expand exp stage (top-level-env)))
- (propagated (propagate-constants expanded (empty-env)))
- (hoisted (hoist-functions* propagated))
- (inferred (infer-types hoisted stage))
- (resolved (resolve-overloads inferred)))
- (pretty-print resolved)
- (emit-glsl resolved version port))))
+ (let ((source* `(top-level ,(append inputs outputs uniforms)
+ ,source)))
+ (define-values (expanded global-map)
+ (expand source* stage (top-level-env)))
+ (let* ((propagated (propagate-constants expanded (empty-env)))
+ (hoisted (hoist-functions* propagated))
+ (inferred (infer-types hoisted stage))
+ (resolved (resolve-overloads inferred)))
+ (make-seagull-module #:stage stage
+ #:inputs inputs
+ #:outputs outputs
+ #:uniforms uniforms
+ #:source source
+ #:compiled resolved
+ #:global-map global-map
+ #:max-id (unique-identifier-counter))))))
+
+(define (group-by-qualifier specs)
+ (let loop ((specs specs)
+ (inputs '())
+ (outputs '())
+ (uniforms '()))
+ (match specs
+ (()
+ `((inputs . ,(reverse inputs))
+ (outputs . ,(reverse outputs))
+ (uniforms . ,(reverse uniforms))))
+ ((spec . rest)
+ (match spec
+ (('in _ _)
+ (loop rest (cons spec inputs) outputs uniforms))
+ (('out _ _)
+ (loop rest inputs (cons spec outputs) uniforms))
+ (('uniform _ _)
+ (loop rest inputs outputs (cons spec uniforms))))))))
+
+(define-syntax-rule (define-shader name stage ((qualifier type var) ...) source)
+ (define name
+ (let ((top-level-defs (group-by-qualifier
+ (list (list 'qualifier 'type 'var) ...))))
+ (compile-seagull-module #:stage 'stage
+ #:source 'source
+ #:inputs (assq-ref top-level-defs 'inputs)
+ #:outputs (assq-ref top-level-defs 'outputs)
+ #:uniforms (assq-ref top-level-defs 'uniforms)))))
+
+(define-syntax-rule (define-vertex-shader name specs source)
+ (define-shader name vertex specs source))
+
+(define-syntax-rule (define-fragment-shader name specs source)
+ (define-shader name fragment specs source))
+
+(define (vertex-outputs-match-fragment-inputs? vertex fragment)
+ (let ((fragment-inputs (seagull-module-inputs fragment)))
+ (every (match-lambda
+ ((_ desc name)
+ (any (match-lambda
+ ((_ desc* name*)
+ (and (eq? name name*)
+ (equal? desc desc*))))
+ fragment-inputs)))
+ (seagull-module-outputs vertex))))
+
+(define (uniforms-compatible? vertex fragment)
+ (let ((fragment-uniforms (seagull-module-uniforms fragment)))
+ (every (match-lambda
+ ((_ desc name)
+ (every (match-lambda
+ ((_ desc* name*)
+ (if (eq? name name*)
+ (equal? desc desc*)
+ #t)))
+ fragment-uniforms)))
+ (seagull-module-outputs vertex))))
+
+(define (rewrite-variables exp subs)
+ (match exp
+ ((? symbol?)
+ (or (assq-ref subs exp) exp))
+ (() '())
+ ((exp* . rest)
+ (cons (rewrite-variables exp* subs)
+ (rewrite-variables rest subs)))
+ (_ exp)))
+
+(define (link-vertex-outputs-with-fragment-inputs vertex fragment)
+ (let* ((vertex-global-map (seagull-module-global-map vertex))
+ (vertex-output-map
+ (map (match-lambda
+ ((_ _ name)
+ (cons name (assq-ref vertex-global-map name))))
+ (seagull-module-outputs vertex)))
+ (vertex-uniform-map
+ (map (match-lambda
+ ((_ _ name)
+ (cons name (assq-ref vertex-global-map name))))
+ (seagull-module-uniforms vertex)))
+ (vertex-uniform-alpha-map
+ (map (match-lambda
+ ((original-name . alpha-name)
+ (cons alpha-name
+ (unique-identifier))))
+ vertex-uniform-map))
+ (vertex-output-alpha-map
+ (map (match-lambda
+ ((original-name . alpha-name)
+ (cons alpha-name
+ (unique-identifier))))
+ vertex-output-map))
+ (fragment-global-map (seagull-module-global-map fragment))
+ (fragment-input-map
+ (map (match-lambda
+ ((_ _ name)
+ (cons name (assq-ref fragment-global-map name))))
+ (seagull-module-inputs fragment)))
+ (fragment-uniform-map
+ (map (match-lambda
+ ((_ _ name)
+ (cons name (assq-ref fragment-global-map name))))
+ (seagull-module-uniforms fragment)))
+ (fragment-uniform-alpha-map
+ (map (match-lambda
+ ((original-name . alpha-name)
+ (cons alpha-name
+ (unique-identifier))))
+ fragment-uniform-map))
+ (fragment-input-alpha-map
+ (append (map (match-lambda
+ ((_ _ name)
+ (cons (assq-ref fragment-global-map
+ name)
+ (assq-ref vertex-output-alpha-map
+ (assq-ref vertex-global-map
+ name)))))
+ (seagull-module-inputs fragment)))))
+ (values (rewrite-variables (seagull-module-compiled vertex)
+ (append vertex-uniform-alpha-map
+ vertex-output-alpha-map))
+ (rewrite-variables (seagull-module-compiled fragment)
+ (append fragment-uniform-alpha-map
+ fragment-input-alpha-map))
+ (append (map (match-lambda
+ ((_ _ name)
+ (cons (assq-ref vertex-uniform-alpha-map
+ (assq-ref vertex-global-map name))
+ name)))
+ (seagull-module-uniforms vertex))
+ (map (match-lambda
+ ((_ _ name)
+ (cons (assq-ref fragment-uniform-alpha-map
+ (assq-ref fragment-global-map name))
+ name)))
+ (seagull-module-uniforms fragment))))))
+
+(define (seagull-module-uniform-map module)
+ (let ((global-map (seagull-module-global-map module)))
+ (map (match-lambda
+ ((_ _ name)
+ (cons (assq-ref global-map name) name)))
+ (seagull-module-uniforms module))))
+
+(define* (link-seagull-modules vertex fragment #:key
+ (version '330))
+ (unless (seagull-module-vertex? vertex)
+ (error "not a vertex shader" vertex))
+ (unless (seagull-module-fragment? fragment)
+ (error "not a fragment shader" fragment))
+ (parameterize ((unique-identifier-counter
+ (max (seagull-module-max-id vertex)
+ (seagull-module-max-id fragment))))
+ (unless (vertex-outputs-match-fragment-inputs? vertex fragment)
+ (error "vertex outputs do not match fragment inputs"))
+ (unless (uniforms-compatible? vertex fragment)
+ (error "vertex uniforms clash with fragment uniforms"))
+ (define-values (vertex* fragment* uniform-map)
+ (link-vertex-outputs-with-fragment-inputs vertex fragment))
+ (define vertex-glsl
+ (call-with-output-string
+ (lambda (port)
+ (emit-glsl vertex* version port))))
+ (define fragment-glsl
+ (call-with-output-string
+ (lambda (port)
+ (emit-glsl fragment* version port))))
+ (display vertex-glsl)
+ (newline)
+ (display fragment-glsl)
+ (newline)
+ (values vertex-glsl fragment-glsl uniform-map)))