diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 84 |
1 files changed, 55 insertions, 29 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index c5452b0..733157b 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -25,23 +25,20 @@ ;; ;; Features: ;; - Purely functional -;; - Vertex and fragment shader output -;; - Targets multiple GLSL versions -;; - Type inference +;; - Statically typed via type inference ;; - Lexical scoping ;; - Nested functions ;; - Multiple return values +;; - Vertex and fragment shader output +;; - Emits code for multiple GLSL versions ;; ;; Limitations: -;; - No first-class functions +;; - First-order functions ;; - No closures ;; - No recursion ;; ;; TODO: ;; - Loops -;; - (define ...) form -;; - struct field aliases (rgba for vec4, for example) maybe a bad idea?? -;; - Scheme shader type -> GLSL struct translation ;; - Dead code elimination (error when a uniform is eliminated) ;; - User defined structs ;; - Multiple GLSL versions @@ -74,9 +71,16 @@ seagull-module-global-map)) ;; The Seagull compiler is designed as a series of source-to-source -;; program transformations in which each transformation pass results -;; in a program that is one step closer to being directly emitted to -;; GLSL code. +;; program transformations (as described in "Compilation by Program +;; Transformation" by Richard Kelsey) in which each transformation +;; pass results in a program that is one step closer to being directly +;; emitted to GLSL code. +;; +;; I wouldn't have been able to write this compiler without the +;; fantastic "An Incremental Approach to Compiler Construction" paper +;; by Abdulaziz Ghuloum that showed me that even a mere mortal could +;; write a useful compiler. Thanks to Christine Lemmer Webber for +;; pointing me to that paper. ;;; @@ -179,7 +183,7 @@ (make-seagull-unbound-variable-error name) (make-exception-with-origin lookup) (make-exception-with-message "seagull: unbound variable") - (make-exception-with-irritants (list name env)))))) + (make-exception-with-irritants (list name (env-names env))))))) (define (lookup* name env) (assq-ref env name)) @@ -247,7 +251,7 @@ (exception-accessor &seagull-syntax-error (record-accessor &seagull-syntax-error 'form))) -(define (seagull-syntax-error exp msg origin) +(define (seagull-syntax-error msg exp origin) (raise-exception (make-exception (make-seagull-syntax-error exp) @@ -291,7 +295,7 @@ (let* ((exps* (map (lambda (exp) (expand exp stage env)) exps)) (env* (compose-envs (alpha-convert names) env)) (bindings* (map list (lookup-all names env*) exps*))) - `(let ,bindings* ,(expand body stage env*))))) + `(let ,bindings* ,(expand `(begin ,@body) stage env*))))) (define (expand:let* bindings body stage env) (match bindings @@ -305,7 +309,7 @@ (define (expand:lambda params body stage env) (define env* (compose-envs (alpha-convert params) env)) (define params* (lookup-all params env*)) - `(lambda ,params* ,(expand body stage env*))) + `(lambda ,params* ,(expand `(begin ,@body) stage env*))) (define (expand:values exps stage env) `(values ,@(expand:list exps stage env))) @@ -334,6 +338,25 @@ (loop `(array-ref ,prev ,(expand j stage env)) rest))))))) +(define (expand:begin definitions body stage env) + (define bindings + (map (match-lambda + (('define (proc-name (? symbol? params) ...) body) + (list proc-name (expand `(lambda ,params ,body) stage env))) + (('define (? symbol? var-name) val) + (list var-name (expand val stage env))) + (invalid + (seagull-syntax-error "invalid definition" invalid expand:begin))) + definitions)) + (define names (map first bindings)) + (define env* (compose-envs (alpha-convert names) env)) + (let loop ((bindings bindings)) + (match bindings + (() + (expand body stage env*)) + (((name value) . rest) + `(let ((,(lookup name env*) ,value)) ,(loop rest)))))) + ;; Arithmetic operators, in true Lisp fashion, can accept many ;; arguments. + and * accept 0 or more. - and / accept one or more. ;; The expansion pass transforms all such expressions into binary @@ -469,9 +492,9 @@ ;; Primitive syntax forms: (('if predicate consequent alternate) (expand:if predicate consequent alternate stage env)) - (('let (((? symbol? names) exps) ...) body) + (('let (((? symbol? names) exps) ...) body ...) (expand:let names exps body stage env)) - (('lambda ((? symbol? params) ...) body) + (('lambda ((? symbol? params) ...) body ...) (expand:lambda params body stage env)) (('values exps ...) (expand:values exps stage env)) @@ -485,6 +508,8 @@ (expand:-> exp members stage env)) (('@ exp indices ...) (expand:@ exp indices stage env)) + (('begin (and ('define _ ...) definitions) ... body) + (expand:begin definitions body stage env)) (('let* (bindings ...) body) (expand:let* bindings body stage env)) (('+ args ...) @@ -2269,9 +2294,9 @@ (define (vars->subs exp env) (match exp (('t ((? variable-type? tvar)) (? symbol? name)) - (let ((type (lookup* name env))) - (if type - (list (cons tvar type)) + (let ((types (lookup* name env))) + (if types + (list (cons tvar (first types))) '()))) ((head . rest) (delete-duplicates @@ -2321,8 +2346,7 @@ (compose-envs env (top-level-type-env stage))))) (define subs* - (compose-substitutions subs - (vars->subs func env))) + (compose-substitutions subs (vars->subs func env))) (define func* (apply-substitutions-to-exp func subs*)) `(function ,name (t (,type*) ,func*))) @@ -2733,16 +2757,17 @@ (define-syntax define-shader-stage (lambda (x) (syntax-case x () - ((_ name stage ((qualifier type var) ...) source) + ((_ name stage ((qualifier type var) ...) source ...) (let* ((globals (group-by-qualifier (syntax->datum #'((qualifier type var) ...)))) (inputs (assq-ref globals 'inputs)) (outputs (assq-ref globals 'outputs)) - (uniforms (assq-ref globals 'uniforms))) + (uniforms (assq-ref globals 'uniforms)) + (source* #'(begin source ...))) (define-values (compiled global-map max-id) (compile-seagull #:stage (syntax->datum #'stage) - #:source (syntax->datum #'source) + #:source (syntax->datum source*) #:inputs inputs #:outputs outputs #:uniforms uniforms)) @@ -2751,7 +2776,8 @@ (uniforms (datum->syntax x uniforms)) (compiled (datum->syntax x compiled)) (global-map (datum->syntax x global-map)) - (max-id (datum->syntax x max-id))) + (max-id (datum->syntax x max-id)) + (source (datum->syntax x source*))) #'(define name (make-seagull-module #:stage 'stage #:inputs (specs->globals 'inputs) @@ -2762,11 +2788,11 @@ #:global-map 'global-map #:max-id max-id)))))))) -(define-syntax-rule (define-vertex-shader name specs source) - (define-shader-stage name vertex specs source)) +(define-syntax-rule (define-vertex-shader name specs source ...) + (define-shader-stage name vertex specs source ...)) -(define-syntax-rule (define-fragment-shader name specs source) - (define-shader-stage name fragment specs source)) +(define-syntax-rule (define-fragment-shader name specs source ...) + (define-shader-stage name fragment specs source ...)) (define (vertex-outputs-match-fragment-inputs? vertex fragment) (let ((fragment-inputs (seagull-module-inputs fragment))) |