diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 253 |
1 files changed, 239 insertions, 14 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 505c4b4..72500fc 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -17,8 +17,8 @@ ;;; Commentary: ;; -;; Seagull is a purely functional, statically typed, Scheme-like -;; language that can be compiled to GLSL code. +;; The Seagull shading language is a purely functional, statically +;; typed, Scheme-like language that can be compiled to GLSL code. ;; ;; Notable features and restrictions: ;; - Vertex and fragment shader output @@ -31,9 +31,10 @@ ;; ;;; Code: (define-module (chickadee graphics seagull) + #:use-module (ice-9 exceptions) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (srfi srfi-9) + #:use-module (srfi srfi-1) #:export (compile-seagull)) ;; The Seagull compiler is designed as a series of source-to-source @@ -43,23 +44,191 @@ ;;; -;;; Alpha conversion +;;; Compiler helpers ;;; +;; This is where we keep miscellaneous code that is useful for many +;; stages of the compiler. + +(define (float? x) + (and (number? x) (inexact? x))) + +;; Immediate types are fundamental data types that need no +;; compilation. +(define (immediate? x) + (or (exact-integer? x) + (float? x) + (char? x) + (boolean? x))) + +(define (primitive-call? x) + (memq x '(+ - * / = < <= > >=))) + + +;;; +;;; Lexical environments +;;; + +;; Environments keep track of the variables that are in scope of an +;; expression. + +(define (empty-env) + '()) + +(define &seagull-unbound-variable-error + (make-exception-type '&seagull-unbound-variable-error &error '(name))) + +(define make-seagull-unbound-variable-error + (record-constructor &seagull-unbound-variable-error)) + +(define seagull-unbound-variable-name + (exception-accessor &seagull-unbound-variable-error + (record-accessor &seagull-unbound-variable-error 'name))) + +(define (lookup name env) + (or (assq-ref env name) + (raise-exception + (make-exception + (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)))))) + +(define (lookup-all names env) + (map (lambda (name) (lookup name env)) names)) + +(define (extend-env name value env) + (alist-cons name value env)) + +(define (compose-envs . envs) + (concatenate envs)) + +(define (top-level-env) + (empty-env)) + + +;;; +;;; Macro expansion and alpha conversion +;;; + +;; Macro expansion converts convenient but non-primitive syntax forms +;; (such as let*) into primitive syntax. Seagull does not currently +;; support user defined macros, just a set of built-ins. +;; ;; Alpha conversion is the process of converting all the user defined ;; identifiers in a program to uniquely named identifiers. This ;; process frees the compiler from having to worry about things like ;; '+' being a user defined variable that shadows the primitive ;; addition operation. +(define unique-identifier-counter (make-parameter 0)) + +(define (unique-identifier-number) + (let ((n (unique-identifier-counter))) + (unique-identifier-counter (+ n 1)) + n)) + +(define (unique-identifier) + (string->symbol + (format #f "V~a" (unique-identifier-number)))) + +(define (alpha-convert names) + (define names* (map (lambda (_name) (unique-identifier)) names)) + (fold extend-env (empty-env) names names*)) + +(define (expand-list exps env) + (map (lambda (exp) (expand exp env)) exps)) + +(define (expand-variable exp env) + ;; Replace original variable with alpha-converted name, but keep + ;; track of the original for showing the user error messages that + ;; make sense later. + `(var ,(lookup exp env) ,exp)) + +(define (expand-if predicate consequent alternate env) + `(if ,(expand predicate env) + ,(expand consequent env) + ,(expand alternate env))) + +(define (expand-let names exps body env) + (if (null? names) + (expand body env) + (let* ((env* (compose-envs (alpha-convert names) env)) + (bindings* (map list (lookup-all names env*) exps))) + `(let ,bindings* ,(expand body env*))))) + +(define (expand-let* bindings body env) + (match bindings + (() (expand body env)) + ((binding . rest) + (expand `(let (,binding) + (let* ,rest ,body)) + env)))) + +(define (expand-lambda params body env) + (define env* (compose-envs (alpha-convert params) env)) + (define params* (lookup-all params env*)) + `(lambda ,params* ,(expand body env*))) + +(define (expand-primitive-call operator operands env) + `(primcall ,operator ,@(expand-list operands env))) + +(define (expand-call operator operands env) + `(call ,(expand operator env) ,@(expand-list operands env))) + +(define &seagull-syntax-error + (make-exception-type '&seagull-syntax-error &error '(form))) + +(define make-seagull-syntax-error + (record-constructor &seagull-syntax-error)) + +(define seagull-syntax-form + (exception-accessor &seagull-syntax-error + (record-accessor &seagull-syntax-error 'form))) + +(define (expand exp env) + (match exp + ;; Immediates and variables: + ((? immediate?) + exp) + ((? symbol?) + (expand-variable exp env)) + ;; Primitive syntax forms: + (('if predicate consequent alternate) + (expand-if predicate consequent alternate env)) + (('let (((? symbol? names) exps) ...) body) + (expand-let names exps body env)) + (('lambda ((? symbol? params) ...) body) + (expand-lambda params body env)) + ;; Macros: + (('let* (bindings ...) body) + (expand-let* bindings body env)) + ;; Primitive calls: + (((? primitive-call? operator) args ...) + (expand-primitive-call operator args env)) + ;; Function calls: + ((operator args ...) + (expand-call operator args env)) + ;; Syntax error: + (_ + (raise-exception + (make-exception + (make-seagull-syntax-error exp) + (make-exception-with-origin expand) + (make-exception-with-message "seagull: invalid syntax") + (make-exception-with-irritants (list exp))))))) + +(define (expand* exp) + (parameterize ((unique-identifier-counter 0)) + (expand exp (top-level-env)))) + ;;; -;;; Macro expansion +;;; Function hoisting ;;; -;; Macro expansion converts convenient but non-primitive syntax forms -;; (such as let*) into primitive syntax. Seagull does not currently -;; support user defined macros, just a set of built-ins. +;; Move all lambda bindings to the top-level. As mentioned earlier, +;; GLSL does not allow nested functions. ;;; @@ -72,13 +241,69 @@ ;; allow free variable references for top-level variables, such as ;; shader inputs and uniforms. - -;;; -;;; Function hoisting -;;; +(define &seagull-scope-error + (make-exception-type '&seagull-scope-error &error '(variable))) + +(define make-seagull-scope-error + (record-constructor &seagull-scope-error)) + +(define seagull-scope-variable + (exception-accessor &seagull-scope-error + (record-accessor &seagull-scope-error 'variable))) + +(define (free-variables exp bound-vars top-level-vars) + (match exp + ((? immediate?) '()) + (('var name original-name) + (cond + ((memq name bound-vars) ; bound vars are not free + '()) + ((memq name top-level-vars) ; free top-level var + (list name)) + (else + ;; Free variables that aren't top-level are not allowed because + ;; GLSL doesn't support closures. + (raise-exception + (make-exception + (make-seagull-scope-error original-name) + (make-exception-with-origin free-variables) + (make-exception-with-message + "seagull: free variable is not top-level") + (make-exception-with-irritants (list exp))))))) + (('if predicate consequent alternate) + (append (free-variables predicate bound-vars top-level-vars) + (free-variables consequent bound-vars top-level-vars) + (free-variables alternate bound-vars top-level-vars))) + (('let ((names _) ...) body) + (free-variables body (append names bound-vars) top-level-vars)) + (('lambda (params ...) body) + (free-variables body (append params bound-vars) top-level-vars)) + ((or ('primcall _ args ...) + ('call args ...)) + (append-map (lambda (arg) + (free-variables arg bound-vars top-level-vars)) + args)))) -;; Move all non-top-level lambda bindings to the top-level. As -;; mentioned earlier, GLSL does not allow nested functions. +(define (annotate-free-variables exp) + (match exp + ((or (? immediate?) + ('var _ _)) + exp) + (('if predicate consequent alternate) + `(if (annotate-free-variables predicate) + (annotate-free-variables consequent) + (annotate-free-variables alternate))) + (('let ((names exps) ...) body) + (define exps* (map annotate-free-variables exps)) + `(let ,(map list names exps*) ,(annotate-free-variables body))) + (('lambda (params ...) body) + ;; TODO: Actually figure out top-level vars. + (define free-vars (free-variables body params '(+ - * /))) + `(lambda ,free-vars ,params ,(annotate-free-variables body))) + (('primcall operator args ...) + `(primcall ,operator ,@(map annotate-free-variables args))) + (('call args ...) + `(call ,@(map annotate-free-variables args))))) ;;; |