diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 291 |
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))) |