diff options
| -rw-r--r-- | Makefile.am | 34 | ||||
| -rw-r--r-- | chickadee/graphics/seagull.scm | 3814 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/base.scm | 313 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/cps.scm | 306 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/glsl.scm | 151 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/pass-expand.scm | 310 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/pass-infer.scm | 182 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/pass-linearize.scm | 256 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/primitives.scm | 142 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/syntax.scm | 95 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/types.scm | 337 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/utils.scm | 124 | ||||
| -rw-r--r-- | chickadee/graphics/sprite.scm | 8 |
13 files changed, 2498 insertions, 3574 deletions
diff --git a/Makefile.am b/Makefile.am index e7578f5..161e4cc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -77,7 +77,16 @@ SOURCES = \ chickadee/graphics/buffer.scm \ chickadee/graphics/pixbuf.scm \ chickadee/graphics/texture.scm \ - chickadee/graphics/seagull.scm \ + chickadee/graphics/seagull/utils.scm \ + chickadee/graphics/seagull/syntax.scm \ + chickadee/graphics/seagull/base.scm \ + chickadee/graphics/seagull/types.scm \ + chickadee/graphics/seagull/cps.scm \ + chickadee/graphics/seagull/primitives.scm \ + chickadee/graphics/seagull/pass-expand.scm \ + chickadee/graphics/seagull/pass-linearize.scm \ + chickadee/graphics/seagull/pass-infer.scm \ + chickadee/graphics/seagull/glsl.scm \ chickadee/graphics/shader.scm \ chickadee/graphics/viewport.scm \ chickadee/graphics/framebuffer.scm \ @@ -102,16 +111,19 @@ SOURCES = \ chickadee/cli/play.scm \ chickadee/cli/bundle.scm -TESTS = \ - tests/base64.scm \ - tests/vector.scm \ - tests/rect.scm \ - tests/matrix.scm \ - tests/array-list.scm \ - tests/heap.scm \ - tests/quadtree.scm \ - tests/queue.scm \ - tests/sglsl.scm +TESTS = \ + tests/base64.scm \ + tests/vector.scm \ + tests/rect.scm \ + tests/matrix.scm \ + tests/array-list.scm \ + tests/heap.scm \ + tests/quadtree.scm \ + tests/queue.scm \ + tests/graphics/seagull/test-pass-expand.scm \ + tests/graphics/seagull/test-pass-linearize.scm \ + tests/graphics/seagull/test-pass-infer.scm \ + tests/graphics/seagull/test-types.scm TEST_EXTENSIONS = .scm SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE) diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 567522f..490e7be 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -1,3565 +1,263 @@ ;;; Chickadee Game Toolkit -;;; Copyright © 2023 David Thompson <davet@gnu.org> +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> ;;; -;;; Chickadee is free software: you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published -;;; by the Free Software Foundation, either version 3 of the License, -;;; or (at your option) any later version. +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at ;;; -;;; Chickadee is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. +;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; <http://www.gnu.org/licenses/>. +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. -;;; Commentary: -;; -;; The Seagull shading language is a purely functional, statically -;; typed, Scheme-like language that compiles to GLSL. The reality of -;; how GPUs work imposes some significant language restrictions, but -;; they are restrictions anyone who writes shader code is already used -;; to. -;; -;; Features: -;; - Purely functional -;; - Statically typed via type inference -;; - Lexical scoping -;; - Nested functions -;; - Multiple return values -;; - Vertex and fragment shader output -;; - Emits code for multiple GLSL versions -;; -;; Limitations: -;; - First-order functions -;; - No closures -;; - No recursion -;; -;; TODO: -;; - Seagull unquote -;; - User defined structs -;; - Loops -;; - Better error messages (especially around type predicate failure) -;; - Helper function modules -;; - Shader composition -;; - Interpreter -;; -;;; Code: (define-module (chickadee graphics seagull) - #:use-module (chickadee graphics engine) - #:use-module (chickadee graphics shader) - #:use-module (ice-9 exceptions) - #:use-module (ice-9 format) - #:use-module (ice-9 match) + #:use-module (chickadee graphics seagull cps) + #:use-module (chickadee graphics seagull glsl) + #:use-module (chickadee graphics seagull pass-expand) + #:use-module (chickadee graphics seagull pass-infer) + #:use-module (chickadee graphics seagull pass-linearize) + #:use-module (chickadee graphics seagull syntax) + #:use-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) #:use-module (ice-9 pretty-print) - #:use-module ((rnrs base) #:select (mod)) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-11) - #:use-module (system repl command) - #:use-module (system repl common) - #:export (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 - compile-seagull-module - compile-shader - link-seagull-modules - define-vertex-shader - define-fragment-shader)) - -;; The Seagull compiler is designed as a series of source-to-source -;; 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. -;; -;; The first pass of the compiler, the expander, converts Seagull code -;; into an intermediate form that uses fewer syntactic forms and -;; renames all variables to be program-unique. A simplifier pass then -;; propagates constants and evaluates expressions that can be computed -;; at compile-time such as (+ 1 2). Each expression is then -;; associated with a type via a type inference pass. The fully typed -;; program can then be emitted directly to GLSL code. There are other -;; passes, but these are the most important. - - -;;; -;;; 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))) - -;; Constant types are fundamental data types that need no compilation. -(define (constant? x) - (or (exact-integer? x) - (float? x) - (boolean? x))) - -(define (top-level-qualifier? x) - (memq x '(in out uniform))) - - -;;; -;;; Lexical environments -;;; - -;; Environments keep track of the variables that are in scope of an -;; expression. - -(define (empty-env) - '()) - -(define-syntax-rule (new-env (key value) ...) - (list (cons key value) ...)) - -(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-names env))))))) - -(define* (lookup* name env #:optional default) - (let loop ((env env)) - (match env - (() default) - (((k . v) . rest) - (if (eq? k name) v (loop rest)))))) - -(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 (env-names env) - (map car env)) - -(define (env-values env) - (map cdr env)) - -(define (env-map proc env) - (map (match-lambda - ((name . exp) - (proc name exp))) - env)) - -(define (env-fold proc init env) - (fold (lambda (e memo) - (match e - ((name . exp) - (proc name exp memo)))) - init - env)) - -(define (env-for-each proc env) - (for-each (match-lambda - ((name . exp) - (proc name exp))) - env)) - - -;;; -;;; Types -;;; - -;; Record types are not used here because these type objects appear in -;; the compiled intermediate form of Seagull, which is generated at -;; compile-time. Record types cannot be interned so simple tagged -;; lists are used instead. -(define-syntax-rule (define-symbolic-type name - constructor predicate (field getter) ...) - (begin - (define (constructor field ...) - (list 'name field ...)) - (define (predicate obj) - (match obj - (('name field ...) #t) - (_ #f))) - (define (getter obj) - (match obj - (('name field ...) - field))) - ...)) - -(define-symbolic-type primitive - primitive-type - primitive-type? - (name primitive-type-name) - (glsl-name primitive-type-glsl-name)) - -(define-symbolic-type outputs - outputs-type - outputs-type?) - -(define-symbolic-type struct - struct-type - struct-type? - (name struct-type-name) - (glsl-name struct-type-glsl-name) - (fields struct-type-fields)) - -(define (struct-type-ref type field) - (assq-ref (struct-type-fields type) field)) - -(define-symbolic-type array - array-type - array-type? - (type array-type-ref) - (length array-type-length)) - -(define unique-variable-type-counter (make-parameter 0)) - -(define (unique-variable-type-number) - (let ((n (unique-variable-type-counter))) - (unique-variable-type-counter (+ n 1)) - n)) - -(define (unique-variable-type-name) - (string->symbol - (format #f "T~a" (unique-variable-type-number)))) - -(define-symbolic-type tvar - variable-type - variable-type? - (name variable-type-name)) - -(define (fresh-variable-type) - (variable-type (unique-variable-type-name))) - -(define (fresh-variable-types-for-list lst) - (map (lambda (_x) (fresh-variable-type)) lst)) - -(define-symbolic-type -> - function-type - function-type? - (parameters function-type-parameters) - (returns function-type-returns)) - -;; For GLSL primitives that support multiple arities. -(define-symbolic-type case-> - function-case-type - function-case-type? - (cases function-case-type-cases)) - -(define (function-case-type-ref type arity) - (assv-ref (function-case-type-cases type) arity)) - -;; For parametric polymorphism. -(define-symbolic-type for-all - type-scheme - type-scheme? - (quantifiers type-scheme-quantifiers) - (type type-scheme-ref)) - -;; For ad-hoc polymorphism. -(define-symbolic-type qualified - qualified-type - qualified-type? - (type qualified-type-ref) - (predicate qualified-type-predicate)) - -(define (type? obj) - (or (primitive-type? obj) - (variable-type? obj) - (function-type? obj) - (function-case-type? obj) - (struct-type? obj) - (outputs-type? obj))) - -;; Type predicates represent additional constraints associated with a -;; typed expression. They are used to implement ad-hoc polymorphism. -;; For example, a function with signature (-> (a a) (a)) could specify -;; the following predicate to allow either ints or floats as arguments: -;; -;; (let ((a (variable-type 'T0))) -;; (predicate:or (predicate:= a type:int) -;; (predicate:= a type:float) -(define-record-type <type-predicate> - (make-type-predicate exp evaluator substituter) - type-predicate? - (exp type-predicate-exp) ; symbolic representation - (evaluator type-predicate-evaluator) ; eval procedure - (substituter type-predicate-substituter)) ; substitute procedure - -(define (print-type-predicate pred port) - (format port "#<type-predicate ~a>" (type-predicate-exp pred))) - -(set-record-type-printer! <type-predicate> print-type-predicate) - -(define predicate:succeed - (make-type-predicate - #t - (lambda () (values predicate:succeed '())) - (lambda (from to) predicate:succeed))) - -(define (predicate:succeed? pred) - (eq? pred predicate:succeed)) - -(define predicate:fail - (make-type-predicate - #f - (lambda () (values predicate:fail '())) - (lambda (from to) predicate:fail))) - -(define (predicate:fail? pred) - (eq? pred predicate:fail)) - -(define (predicate:= a b) - (cond - ((or (variable-type? a) - (variable-type? b)) - (make-type-predicate - `(= ,a ,b) - (lambda () - (values (predicate:= a b) '())) - (lambda (from to) - (predicate:= (apply-substitution-to-type a from to) - (apply-substitution-to-type b from to))))) - ((equal? a b) - predicate:succeed) - (else - predicate:fail))) - -(define (predicate:substitute a b) - (make-type-predicate - `(substitute ,a ,b) - (lambda () - (values predicate:succeed (list (cons a b)))) - (lambda (from to) - (predicate:substitute (apply-substitution-to-type a from to) - (apply-substitution-to-type b from to))))) - -(define (predicate:struct-field struct field field-var) - (cond - ((struct-type? struct) - (let ((field-type (struct-type-ref struct field))) - (if field-type - (predicate:substitute field-var field-type) - predicate:fail))) - ((variable-type? struct) - (make-type-predicate - `(struct-field ,struct ,field ,field-var) - (lambda () - (values (predicate:struct-field struct field field-var) '())) - (lambda (from to) - (predicate:struct-field - (apply-substitution-to-type struct from to) - field - (apply-substitution-to-type field-var from to))))) - (else predicate:fail))) - -(define (predicate:array-element array element-var) - (cond - ((array-type? array) - (predicate:substitute element-var (array-type-ref array))) - ((variable-type? array) - (make-type-predicate - `(array-element ,array ,element-var) - (lambda () - (values (predicate:array-element array element-var) '())) - (lambda (from to) - (predicate:array-element - (apply-substitution-to-type array from to) - (apply-substitution-to-type element-var from to))))) - (else predicate:fail))) - -;; All the predicates must succeed, but unlike 'predicate:and', they -;; can succeed independently of one another. -(define (predicate:compose pred . rest) - (if (null? rest) - pred - (let ((other (apply predicate:compose rest))) - (cond - ((and (predicate:succeed? pred) (predicate:succeed? other)) - predicate:succeed) - ((predicate:succeed? pred) - other) - ((predicate:succeed? other) - pred) - (else - (make-type-predicate - `(compose ,(type-predicate-exp pred) - ,(type-predicate-exp other)) - (lambda () - (let-values (((pred* pred-subs) (eval-predicate pred))) - (cond - ;; Left succeeds, now check the right. - ((predicate:succeed? pred*) - (let-values (((other* other-subs) (eval-predicate other))) - (cond - ;; Right succeeds, the composition is a success. - ((predicate:succeed? other*) - (values predicate:succeed - (compose-substitutions pred-subs other-subs))) - ;; Right fails, so the composition fails. - ((predicate:fail? other*) - (values predicate:fail '())) - ;; Also inconclusive, return the same composition. - (else - (values other pred-subs))))) - ;; Left fails, so the composition fails. - ((predicate:fail? pred*) - (values predicate:fail '())) - ;; Left predicate is inconclusive, try the right. - (else - (let-values (((other* other-subs) (eval-predicate other))) - (cond - ;; Right succeeds, return the left. - ((predicate:succeed? other*) - (values pred other-subs)) - ;; Right fails, so the composition fails. - ((predicate:fail? other*) - (values predicate:fail '())) - ;; Also inconclusive, return the same composition. - (else - (values (predicate:compose pred other) '())))))))) - (lambda (from to) - (predicate:compose - (apply-substitution-to-predicate pred from to) - (apply-substitution-to-predicate other from to))))))))) - -;; The 'and' predicate succeeds if and when all the given predicates -;; succeed. -(define (predicate:and . preds) - (match (remove predicate:succeed? preds) - (() - predicate:succeed) - ((pred) - pred) - ((or ((? predicate:fail?) _) - (_ (? predicate:fail?))) - predicate:fail) - ((a b) - (make-type-predicate - `(and ,(type-predicate-exp a) ,(type-predicate-exp b)) - (lambda () - (let-values (((a* a-subs) (eval-predicate a))) - (cond - ;; Left succeeds, now try the right. - ((predicate:succeed? a*) - (let-values (((b* b-subs) (eval-predicate b))) - (cond - ;; Right succeeds, so the 'and' succeeds. - ((predicate:succeed? b*) - (values predicate:succeed - (compose-substitutions a-subs b-subs))) - ;; Right fails, so the 'and' fails. - ((predicate:fail? b*) - (values predicate:fail '())) - ;; Right is inconclusive, so return the same 'and'. - (else - (predicate:and a b))))) - ;; Left fails, so the 'and' fails. - ((predicate:fail? a*) - (values predicate:fail '())) - ;; Left is inconclusive, so return the same 'and'. - (else - (values (predicate:and a b) '()))))) - (lambda (from to) - (predicate:and (apply-substitution-to-predicate a from to) - (apply-substitution-to-predicate b from to))))) - ((a . rest) - (predicate:and a (apply predicate:and rest))))) - -;; The 'or' predicate succeeds if and when any given predicate -;; succeeds. -(define (predicate:or . preds) - (match (remove predicate:fail? preds) - (() - predicate:fail) - ((pred) - pred) - ((or ((? predicate:succeed?) _) - (_ (? predicate:succeed?))) - predicate:succeed) - ((a b) - (make-type-predicate - `(or ,(type-predicate-exp a) ,(type-predicate-exp b)) - (lambda () - (let-values (((a* a-subs) (eval-predicate a))) - (cond - ;; Left succeeds, so the 'or' succeeds. - ((predicate:succeed? a*) - (values predicate:succeed a-subs)) - ;; Left fails, so remove the 'or' and eval the right. - ((predicate:fail? a*) - (eval-predicate b)) - ;; Left is inconclusive, check the right. - (else - (let-values (((b* b-subs) (eval-predicate b))) - (cond - ;; Right succeeds, so the 'or' succeeds. - ((predicate:succeed? b*) - (values predicate:succeed b-subs)) - ;; Right fails, so remove the 'or' and return the left. - ((predicate:fail? b*) - (values a '())) - (else - (values (predicate:or a b) '())))))))) - (lambda (from to) - (predicate:or (apply-substitution-to-predicate a from to) - (apply-substitution-to-predicate b from to))))) - ((a . rest) - (predicate:or a (apply predicate:or rest))))) - -(define (predicate:any var . types) - (apply predicate:or - (map (lambda (type) - (predicate:= var type)) - types))) - -(define (apply-substitution-to-predicate pred from to) - ((type-predicate-substituter pred) from to)) - -(define (apply-substitutions-to-predicate pred subs) - (env-fold (lambda (from to pred*) - (apply-substitution-to-predicate pred* from to)) - pred - subs)) - -(define (eval-predicate pred) - ((type-predicate-evaluator pred))) - -(define (eval-predicate* pred subs) - (define-values (new-pred pred-subs) - (eval-predicate - (apply-substitutions-to-predicate pred subs))) - ;; TODO: Get information about *why* the predicate failed. - (unless new-pred - (seagull-type-error "type predicate failed" (list pred) eval-predicate*)) - ;; Recursively evaluate the predicate, applying the substitutions - ;; generated by the last evaluation, until it cannot be simplified - ;; any further. - (if (null? pred-subs) - (values new-pred subs) - (eval-predicate* new-pred (compose-substitutions subs pred-subs)))) - -;; Built-in type registry. -(define *types* (make-hash-table)) - -(define (lookup-type name) - (hashq-ref *types* name)) - -(define (register-type! name type) - (hashq-set! *types* name type)) - -(define-syntax define-primitive-type - (syntax-rules () - ((_ var-name seagull-name) - (define-primitive-type var-name - seagull-name (symbol->string 'seagull-name))) - ((_ var-name seagull-name glsl-name) - (begin - (define var-name (primitive-type 'seagull-name glsl-name)) - (register-type! 'seagull-name var-name))))) - -(define-syntax define-struct-type - (syntax-rules () - ((_ (var-name seagull-name) (types names) ...) - (define-struct-type (var-name seagull-name (symbol->string 'seagull-name)) - (types names) ...)) - ((_ (var-name seagull-name glsl-name) (types names) ...) - (begin - (define var-name (struct-type 'seagull-name glsl-name - (list (cons 'names types) ...))) - (register-type! 'seagull-name var-name))))) - -;; Built-in types: -(define-primitive-type type:int int) -(define-primitive-type type:float float) -(define-primitive-type type:bool bool) -(define-struct-type (type:vec2 vec2) - (type:float x) - (type:float y)) -(define-struct-type (type:vec3 vec3) - (type:float x) - (type:float y) - (type:float z)) -(define-struct-type (type:vec4 vec4) - (type:float x) - (type:float y) - (type:float z) - (type:float w)) -;; TODO: Matrices are technically array types in GLSL, but we are -;; choosing to represent them opaquely for now to keep things simple. -(define-primitive-type type:mat3 mat3) -(define-primitive-type type:mat4 mat4) -(define-primitive-type type:sampler-2d sampler-2d "sampler2D") -(define type:outputs (outputs-type)) - - -;;; -;;; Built-in variables -;;; - -(define-record-type <seagull-variable> - (%make-seagull-variable name glsl-name type stages qualifier) - seagull-variable? - (name seagull-variable-name) - (glsl-name seagull-variable-glsl-name) - (type seagull-variable-type) - (stages seagull-variable-stages) - (qualifier seagull-variable-qualifier)) - -(define* (make-seagull-variable name #:key glsl-name type stages qualifier) - (%make-seagull-variable name glsl-name type stages qualifier)) - -(define (output-variable? variable) - (eq? (seagull-variable-qualifier variable) 'output)) - -(define (input-variable? variable) - (eq? (seagull-variable-qualifier variable) 'input)) - -(define (variable-for-stage? variable stage) - (memq stage (seagull-variable-stages variable))) - -(define *seagull-variables* (make-hash-table)) - -(define (register-seagull-variable! variable) - (hashq-set! *seagull-variables* - (seagull-variable-name variable) - variable)) - -(define (find-variables pred) - (hash-fold (lambda (k v memo) - (if (pred v) - (cons v memo) - memo)) - '() - *seagull-variables*)) - -(define (lookup-output-variable name) - (let ((variable (hashq-ref *seagull-variables* name))) - (and (seagull-variable? variable) - (output-variable? variable) - variable))) - -(define (lookup-output-variable-for-stage name stage) - (let ((variable (lookup-output-variable name))) - (and (seagull-variable? variable) - (variable-for-stage? variable stage) - variable))) - -(define (lookup-input-variable name) - (let ((variable (hashq-ref *seagull-variables* name))) - (and (seagull-variable? variable) - (input-variable? variable) - variable))) - -(define-syntax-rule (define-seagull-variable name args ...) - (register-seagull-variable! (make-seagull-variable 'name args ...))) - -(define-seagull-variable vertex:position - #:glsl-name "gl_Position" - #:type type:vec4 - #:stages '(vertex) - #:qualifier 'output) - -(define-seagull-variable vertex:point-size - #:glsl-name "gl_PointSize" - #:type type:float - #:stages '(vertex) - #:qualifier 'output) - -(define-seagull-variable vertex:clip-distance - #:glsl-name "gl_ClipDistance" - #:type type:float - #:stages '(vertex) - #:qualifier 'output) - -(define-seagull-variable fragment:depth - #:glsl-name "gl_FragDepth" - #:type type:float - #:stages '(fragment) - #:qualifier 'output) - -(define-seagull-variable fragment:coord - #:glsl-name "gl_FragCoord" - #:type type:vec4 - #:stages '(fragment) - #:qualifier 'input) - - -;;; -;;; Primitives -;;; - -(define-record-type <seagull-primitive> - (%make-seagull-primitive name glsl-name stages type proc expand emit) - seagull-primitive? - (name seagull-primitive-name) - (glsl-name seagull-primitive-glsl-name) - (stages seagull-primitive-stages) - (type seagull-primitive-type) - (proc seagull-primitive-proc) - (expand seagull-primitive-expand) - (emit seagull-primitive-emit)) - -(define (make-default-expander name) - (define (expand:default args stage env) - `(primcall ,name ,@(expand:list args stage env))) - expand:default) - -(define (make-default-emitter name) - (define (emit:default args port) - (format port "~a(~a)" - name - (string-join (map symbol->string args) ", "))) - emit:default) - -(define (make-infix-emitter name) - (define (emit:infix args port) - (match args - ((a b) - (format port "~a ~a ~a" a name b)))) - emit:infix) - -(define* (make-seagull-primitive #:key name type proc - (glsl-name name) - (stages '(vertex fragment)) - (expand (make-default-expander name)) - (emit (make-default-emitter glsl-name))) - (%make-seagull-primitive name glsl-name stages type proc expand emit)) - -(define *seagull-primitives* (make-hash-table)) - -(define (register-seagull-primitive! primitive) - (hashq-set! *seagull-primitives* - (seagull-primitive-name primitive) - primitive) - *unspecified*) - -(define (lookup-seagull-primitive name) - (hashq-ref *seagull-primitives* name)) - -(define-syntax-rule (define-seagull-primitive name args ...) - (register-seagull-primitive! - (make-seagull-primitive #:name 'name args ...))) - -(define (primitive-call? x stage) - (let ((primitive (lookup-seagull-primitive x))) - (and (seagull-primitive? primitive) - (memq stage (seagull-primitive-stages primitive))))) - -(define-syntax-rule (-> (params ...) (returns ...)) - (function-type (list params ...) (list returns ...))) - -(define-syntax-rule (->case (arity type) ...) - (function-case-type `((arity . ,type) ...))) - -(define-syntax overload - (syntax-rules (->) - ((_ ((var types ...) ...) (-> (args ...) (returns ...))) - (parameterize ((unique-variable-type-counter 0)) - (let ((var (fresh-variable-type)) ...) - (type-scheme - (list var ...) - (qualified-type - (function-type (list args ...) (list returns ...)) - (predicate:compose - (predicate:any var types ...) ...)))))))) - -(define-syntax-rule (a+b->c (ta tb tc) ...) - (parameterize ((unique-variable-type-counter 0)) - (let ((a (fresh-variable-type)) - (b (fresh-variable-type)) - (c (fresh-variable-type))) - (type-scheme - (list a b c) - (qualified-type - (function-type (list a b) (list c)) - (predicate:or - (predicate:and (predicate:= a ta) - (predicate:= b tb) - (predicate:substitute c tc)) - ...)))))) - -(define-syntax-rule (a+b+c->d (ta tb tc td) ...) - (parameterize ((unique-variable-type-counter 0)) - (let ((a (fresh-variable-type)) - (b (fresh-variable-type)) - (c (fresh-variable-type)) - (d (fresh-variable-type))) - (type-scheme - (list a b c d) - (qualified-type - (function-type (list a b c) (list d)) - (predicate:or - (predicate:and (predicate:= a ta) - (predicate:= b tb) - (predicate:= c tc) - (predicate:substitute d td)) - ...)))))) - -(define-seagull-primitive + - #:type (overload ((a type:int type:float - type:vec2 type:vec3 type:vec4 - type:mat3 type:mat4)) - (-> (a a) (a))) - #:proc + - #:expand - (lambda (args stage env) - (let loop ((args args)) - (match args - (() 0) - ((n) (expand n stage env)) - ((n . rest) - `(primcall + ,(expand n stage env) ,(loop rest)))))) - #:emit (make-infix-emitter '+)) - -(define-seagull-primitive - - #:type (overload ((a type:int type:float - type:vec2 type:vec3 type:vec4 - type:mat3 type:mat4)) - (-> (a a) (a))) - #:proc - - #:expand - (lambda (args stage env) - (let loop ((args args)) - (match args - ((n) `(primcall - ,(expand n stage env) 0)) - ((m n) - `(primcall - ,(expand m stage env) ,(expand n stage env))) - ((n . rest) - `(primcall - ,(expand n stage env) ,(loop rest)))))) - #:emit (make-infix-emitter '-)) - -(define-seagull-primitive * - #:type (a+b->c (type:int type:int type:int) - (type:float type:float type:float) - (type:int type:float type:float) - (type:float type:int type:float) - (type:vec2 type:vec2 type:vec2) - (type:vec2 type:float type:vec2) - (type:float type:vec2 type:vec2) - (type:vec3 type:vec3 type:vec3) - (type:vec3 type:float type:vec3) - (type:float type:vec3 type:vec3) - (type:vec4 type:vec4 type:vec4) - (type:vec4 type:float type:vec4) - (type:float type:vec4 type:vec4) - (type:mat3 type:mat3 type:mat3) - (type:mat3 type:vec3 type:vec3) - (type:vec3 type:mat3 type:vec3) - (type:mat4 type:mat4 type:mat4) - (type:mat4 type:vec4 type:vec4) - (type:vec4 type:mat4 type:vec4)) - #:proc * - #:expand - (lambda (args stage env) - (let loop ((args args)) - (match args - (() 1) - ((n) (expand n stage env)) - ((n . rest) - `(primcall * ,(expand n stage env) ,(loop rest)))))) - #:emit (make-infix-emitter '*)) - -(define-seagull-primitive / - #:type (a+b->c (type:int type:int type:int) - (type:float type:float type:float) - (type:float type:int type:float) - (type:int type:float type:float) - (type:vec2 type:vec2 type:vec2) - (type:vec2 type:float type:vec2) - (type:vec3 type:vec3 type:vec3) - (type:vec3 type:float type:vec3) - (type:vec4 type:vec4 type:vec4) - (type:vec4 type:float type:vec4) - (type:mat3 type:float type:mat3) - (type:mat4 type:float type:mat4)) - ;; The division of two integers can result in a rational, - ;; non-integer, such as 1/2. This isn't how integer division works - ;; in GLSL, so we need to round the result to an integer. - #:proc - (lambda (x y) - (let ((result (/ x y))) - (if (or (float? result) (integer? result)) - result - (round result)))) - #:expand - (lambda (args stage env) - (match args - ((n) - `(primcall / 1 ,(expand n stage env))) - ((m n) - `(primcall / ,(expand m stage env) ,(expand n stage env))) - ((m n . rest) - (let loop ((rest rest) - (exp `(primcall / ,(expand m stage env) ,(expand n stage env)))) - (match rest - ((l) - `(primcall / ,exp ,(expand l stage env))) - ((l . rest) - (loop rest `(primcall / ,exp ,(expand l stage env))))))))) - #:emit (make-infix-emitter '/)) - -(define-seagull-primitive mod - #:type (a+b->c (type:float type:float type:float) - (type:int type:int type:float) - (type:vec2 type:vec2 type:vec2) - (type:vec3 type:vec3 type:vec3) - (type:vec4 type:vec4 type:vec4) - (type:vec2 type:float type:vec2) - (type:vec3 type:float type:vec3) - (type:vec4 type:float type:vec4)) - #:proc mod) - -(define-seagull-primitive floor - #:type (overload ((a type:float type:vec2 type:vec3 type:vec4)) - (-> (a) (a))) - #:proc floor) - -(define-seagull-primitive ceiling - #:glsl-name 'ceil - #:type (overload ((a type:float type:vec2 type:vec3 type:vec4)) - (-> (a) (a))) - #:proc ceiling) - -(define-seagull-primitive int->float - #:glsl-name 'float - #:type (-> (type:int) (type:float)) - #:proc exact->inexact) - -(define-seagull-primitive float->int - #:glsl-name 'int - #:type (-> (type:float) (type:int)) - #:proc (compose inexact->exact floor)) - -(define (make-comparison-expander name) - (lambda (args stage env) - (match args - (() #t) - ((x) - (expand `(let ((x* ,x)) (,name x* x*)) stage env)) - ((x y) - `(primcall ,name ,(expand x stage env) ,(expand y stage env))) - ((x y . rest) - (expand `(let ((y* ,y)) - (and (,name ,x y*) - ,(let loop ((rest rest) - (prev 'y*)) - (match rest - ((z) - (list name prev z)) - ((z . rest) - `(let ((z* ,z)) - (and (,name ,prev z*) - ,(loop rest 'z*)))))))) - stage env))))) - -(define-syntax define-comparison-primitive - (syntax-rules () - ((_ name) - (define-comparison-primitive name name - (make-comparison-expander 'name))) - ((_ name glsl-name) - (define-comparison-primitive name glsl-name - (make-comparison-expander 'name))) - ((_ name glsl-name expand) - (define-seagull-primitive name - #:glsl-name 'glsl-name - #:type - (overload ((a type:int type:float)) - (-> (a a) (type:bool))) - #:proc name - #:expand expand - #:emit (make-infix-emitter 'glsl-name))))) - -(define-comparison-primitive = == - (lambda (args stage env) - (match args - (() #t) - ((x) - (expand `(let ((x* ,x)) (= x* x*)) stage env)) - ((x y) - `(primcall = ,(expand x stage env) ,(expand y stage env))) - ((x . rest) - (expand `(let ((x* ,x)) - (and ,@(map (lambda (y) `(= x* ,y)) rest))) - stage env))))) - -(define-comparison-primitive <) -(define-comparison-primitive <=) -(define-comparison-primitive >) -(define-comparison-primitive >=) - -(define-seagull-primitive not - #:glsl-name '! - #:type (-> (type:bool) (type:bool)) - #:emit - (lambda (args port) - (match args - ((a) - (format port "!(~a)" a))))) - -(define-seagull-primitive vec2 - #:type (->case - (1 (-> (type:float) (type:vec2))) - (2 (-> (type:float type:float) (type:vec2))))) - -(define-seagull-primitive vec3 - #:type (->case - (1 (-> (type:float) (type:vec3))) - (2 (a+b->c (type:float type:vec2 type:vec3) - (type:vec2 type:float type:vec3))) - (3 (-> (type:float type:float type:float) (type:vec3))))) - -(define-seagull-primitive vec4 - #:type (->case - (1 (-> (type:float) (type:vec4))) - (2 (a+b->c (type:vec2 type:vec2 type:vec4) - (type:vec3 type:float type:vec4) - (type:float type:vec3 type:vec4))) - (3 (a+b+c->d (type:vec2 type:float type:float type:vec4) - (type:float type:vec2 type:float type:vec4) - (type:float type:float type:vec2 type:vec4))) - (4 (-> (type:float type:float type:float type:float) (type:vec4))))) - -(define-seagull-primitive length - #:type (overload ((a type:float type:vec2 type:vec3 type:vec4)) - (-> (a) (type:float)))) - -(define-seagull-primitive abs - #:type (overload ((a type:int type:float)) - (-> (a) (a))) - #:proc abs) - -(define-seagull-primitive sqrt - #:type (-> (type:float) (type:float)) - #:proc sqrt) - -(define-seagull-primitive expt - #:glsl-name 'pow - #:type (overload ((a type:float type:vec2 type:vec3 type:vec4)) - (-> (a a) (a))) - #:proc expt) - -(define-seagull-primitive min - #:type (overload ((a type:int type:float)) (-> (a a) (a))) - #:proc min) - -(define-seagull-primitive max - #:type (overload ((a type:int type:float)) (-> (a a) (a))) - #:proc min) - -(define-seagull-primitive sin - #:type (-> (type:float) (type:float)) - #:proc sin) - -(define-seagull-primitive cos - #:type (-> (type:float) (type:float)) - #:proc cos) - -(define-seagull-primitive tan - #:type (-> (type:float) (type:float)) - #:proc tan) - -(define-seagull-primitive clamp - #:type (overload ((a type:int type:float)) (-> (a a a) (a)))) - -(define-seagull-primitive mix - #:type (overload ((a type:int type:float type:vec2 type:vec3 type:vec4)) - (-> (a a type:float) (a)))) - -(define-seagull-primitive step - #:type (a+b->c (type:float type:float type:float) - (type:vec2 type:vec2 type:vec2) - (type:vec3 type:vec3 type:vec3) - (type:vec4 type:vec4 type:vec4) - (type:float type:vec2 type:vec2) - (type:float type:vec3 type:vec3) - (type:float type:vec4 type:vec4))) - -(define-seagull-primitive smoothstep - #:type (a+b+c->d (type:float type:float type:float type:float) - (type:vec2 type:vec2 type:vec2 type:vec2) - (type:vec3 type:vec3 type:vec3 type:vec3) - (type:vec4 type:vec4 type:vec4 type:vec4) - (type:float type:float type:vec2 type:vec2) - (type:float type:float type:vec3 type:vec3) - (type:float type:float type:vec4 type:vec4))) - -(define-seagull-primitive texture - #:stages '(fragment) - #:type (-> (type:sampler-2d type:vec2) (type:vec4))) - - -;;; -;;; 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 &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 (seagull-syntax-error msg exp origin) - (raise-exception - (make-exception - (make-seagull-syntax-error exp) - (make-exception-with-origin origin) - (make-exception-with-message - (format #f "seagull syntax error: ~a" msg)) - (make-exception-with-irritants (list exp))))) - -(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 (unique-identifiers-for-list lst) - (map (lambda (_x) (unique-identifier)) lst)) - -(define (expand:top-level-env stage) - (fold (lambda (v env) - (let ((name (seagull-variable-name v))) - (extend-env name name env))) - (empty-env) - (find-variables - (lambda (v) - (and (input-variable? v) - (variable-for-stage? v stage)))))) - -(define (alpha-convert names) - (define names* (map (lambda (_name) (unique-identifier)) names)) - (fold extend-env (empty-env) names names*)) - -(define (expand:list exps stage env) - (map (lambda (exp) (expand exp stage env)) exps)) - -(define (expand:variable exp stage env) - (lookup exp env)) - -(define (expand:if predicate consequent alternate stage env) - `(if ,(expand predicate stage env) - ,(expand consequent stage env) - ,(expand alternate stage env))) - -(define (expand:let names exps body stage env) - (if (null? names) - (expand body stage env) - (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 `(begin ,@body) stage env*))))) - -(define (expand:let-values names exps body stage env) - (if (null? names) - (expand body stage env) - (let* ((exps* (map (lambda (exp) - (expand exp stage env)) - exps)) - (env* (fold (lambda (names* env*) - (compose-envs (alpha-convert names*) env*)) - env - names)) - (bindings* (map list - (map (lambda (names*) - (lookup-all names* env*)) - names) - exps*))) - `(let-values ,bindings* ,(expand `(begin ,@body) stage env*))))) - -(define (expand:let* bindings body stage env) - (match bindings - (() (expand body stage env)) - ((binding . rest) - (expand `(let (,binding) - (let* ,rest ,body)) - stage - env)))) - -(define (expand:let*-values bindings body stage env) - (match bindings - (() (expand body stage env)) - ((binding . rest) - (expand `(let-values (,binding) - (let*-values ,rest ,body)) - stage - env)))) - -(define (expand:lambda params body stage env) - (define env* (compose-envs (alpha-convert params) env)) - (define params* (lookup-all params env*)) - `(lambda ,params* ,(expand `(begin ,@body) stage env*))) - -(define (expand:values exps stage env) - `(values ,@(expand:list exps stage env))) - -(define (expand:-> exp fields stage env) - (define exp* (expand exp stage env)) - (match fields - ((field . rest) - (let loop ((fields rest) - (prev `(struct-ref ,exp* ,field))) - (match fields - (() prev) - ((next . rest) - (loop `(struct-ref ,prev ,next) - rest))))))) - -(define (expand:@ exp indices stage env) - (define exp* (expand exp stage env)) - (match indices - ((i . rest) - (let loop ((indices rest) - (prev `(array-ref ,exp* ,(expand i stage env)))) - (match indices - (() prev) - ((j . rest) - (loop `(array-ref ,prev ,(expand j stage env)) - rest))))))) - -(define (expand:begin body stage env) - (match body - (((and ('define _ ...) definitions) ... body) - (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)))))) - (_ - (seagull-syntax-error "invalid begin form" `(begin ,@body) expand:begin)))) - -(define (expand:or exps stage env) - (match exps - (() #f) - ((exp . rest) - (expand `(let ((x ,exp)) (if x x (or ,@rest))) - stage env)))) - -(define (expand:and exps stage env) - (match exps - (() #t) - ((exp . rest) - (expand `(let ((x ,exp)) (if x (and ,@rest) #f)) - stage env)))) - -(define (expand:cond clauses stage env) - (define (cond->if clauses*) - (match clauses* - ;; Our version of 'cond' requires a final else clause because the - ;; static type checker enforces that both branches of an 'if' must - ;; be the same type. If 'else' were optional then we wouldn't - ;; know what type the final alternate branch should be. - ((('else exp)) - exp) - (((predicate consequent) . rest) - `(if ,predicate - ,consequent - ,(cond->if rest))) - (() - (seagull-syntax-error "'cond' form must end with 'else' clause" - `(cond ,@clauses) - expand:cond)) - (_ - (seagull-syntax-error "invalid 'cond' form" - `(cond ,@clauses) - expand:cond)))) - (expand (cond->if clauses) stage env)) - -(define (expand:case key clauses stage env) - (define (case->if clauses*) - (match clauses* - ;; Like 'cond', 'case' also requires a final 'else' clause. - ((('else exp)) - exp) - ((((possibilities ..1) consequent) . rest) - `(if (or ,@(map (lambda (n) `(= key ,n)) possibilities)) - ,consequent - ,(case->if rest))) - (() - (seagull-syntax-error "'case' form must end with 'else' clause" - `(case ,key ,@clauses) - expand:case)) - (_ - (seagull-syntax-error "invalid 'cond' form" - `(case ,key ,@clauses) - expand:case)))) - (expand `(let ((key ,key)) ,(case->if clauses)) stage env)) - -(define (expand:primitive-call operator operands stage env) - (let ((primitive (lookup-seagull-primitive operator))) - ((seagull-primitive-expand primitive) operands stage env))) - -(define (expand:call operator operands stage env) - `(call ,(expand operator stage env) ,@(expand:list operands stage env))) - -(define (expand:top-level qualifiers types names body stage env) - (let* ((global-map (alpha-convert names)) - (env* (compose-envs global-map env))) - ;; TODO: Support interpolation qualifiers. - (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 - ,@(map (lambda (name exp) - (let ((variable (lookup-output-variable-for-stage name stage))) - (list (if (seagull-variable? variable) - (seagull-variable-name variable) - ;; TODO: Check that the variable is an output - ;; variable. - (lookup name env)) - (expand exp stage env)))) - names exps))) - -(define (expand:discard stage env) - (if (eq? stage 'fragment) - '(outputs) - (seagull-syntax-error "discard not allowed in vertex shader" exp expand))) - -(define (expand exp stage env) - (define (primitive-call-for-stage? x) - (primitive-call? x stage)) - (match exp - ;; Constants and variables: - ((? constant?) - exp) - ((? symbol?) - (expand:variable exp stage env)) - ;; Primitive syntax forms: - (('if predicate consequent alternate) - (expand:if predicate consequent alternate stage env)) - (('let (((? symbol? names) exps) ...) body ...) - (expand:let names exps body stage env)) - (('let-values ((((? symbol? names) ...) exps) ...) body ...) - (expand:let-values names exps body stage env)) - (('lambda ((? symbol? params) ...) body ...) - (expand:lambda params body stage env)) - (('values exps ...) - (expand:values exps stage env)) - (('outputs ((? symbol? names) exps) ...) - (expand:outputs names exps stage env)) - (('top-level (((? top-level-qualifier? qualifiers) types names) ...) - body) - (expand:top-level qualifiers types names body stage env)) - ;; Macros: - (('-> exp (? symbol? members) ..1) - (expand:-> exp members stage env)) - (('@ exp indices ...) - (expand:@ exp indices stage env)) - (('begin body ...) - (expand:begin body stage env)) - (('let* (bindings ...) body) - (expand:let* bindings body stage env)) - (('let*-values (bindings ...) body) - (expand:let*-values bindings body stage env)) - (('or exps ...) - (expand:or exps stage env)) - (('and exps ...) - (expand:and exps stage env)) - (('cond clauses ...) - (expand:cond clauses stage env)) - (('case key clauses ...) - (expand:case key clauses stage env)) - (('discard) - (expand:discard stage env)) - ;; Primitive calls: - (((? primitive-call-for-stage? operator) args ...) - (expand:primitive-call operator args stage env)) - ;; Function calls: - ((operator args ...) - (expand:call operator args stage env)) - ;; Syntax error: - (_ - (seagull-syntax-error "unknown form" exp expand)))) - -(define (expand* exp stage) - (expand exp stage (expand:top-level-env stage))) - - -;;; -;;; Constant propagation and folding -;;; - -;; Replace references to constants (variables that store an constant -;; value: integer, float, boolean) with the constants themselves. -;; Then look for opportunities to evaluate primitive expressions that -;; have constant arguments. This will make the type inferencer's job -;; a bit easier. - -(define (simplify:list exps env) - (map (lambda (exp) (simplify exp env)) exps)) - -(define (simplify:if predicate consequent alternate env) - (define predicate* (simplify predicate env)) - (cond - ((eq? predicate* #t) - (simplify consequent env)) - ((eq? predicate* #f) - (simplify alternate env)) - (else - `(if ,predicate* - ,(simplify consequent env) - ,(simplify alternate env))))) - -(define (simplify:lambda params body env) - `(lambda ,params ,(simplify body env))) - -(define (simplify:values exps env) - `(values ,@(simplify:list exps env))) - -(define (simplify:let names exps body env) - (define exps* (simplify:list exps env)) - ;; Extend environment with known constants. - (define env* - (fold (lambda (name exp env*) - (if (constant? exp) - (extend-env name exp env*) - env*)) - env names exps*)) - ;; Drop all bindings for constant expressions. - (define bindings - (filter-map (lambda (name exp) - (if (constant? exp) - #f - (list name exp))) - names exps*)) - ;; If there are no bindings left, remove the 'let' entirely. - (if (null? bindings) - (simplify body env*) - `(let ,bindings - ,(simplify body env*)))) - -(define (simplify:let-values names exps body env) - (define exps* (simplify:list exps env)) - ;; Extend environment with known constants. - (define env* - (fold (lambda (names exp env) - (match exp - ((? constant?) - (match names - ((name) - (extend-env name exp env)))) - (('values vals ...) - (fold (lambda (name val env) - (if (constant? val) - (extend-env name val env) - env)) - env names vals)) - (_ env))) - env names exps*)) - ;; Drop all bindings for constant expressions. - (define bindings - (filter-map (lambda (names exp) - (match exp - ((? constant?) #f) - (('values vals ...) - (define-values (names* exps*) - (unzip2 - (filter-map (lambda (name val) - (if (constant? val) - #f - (list name val))) - names vals))) - (if (null? names*) - #f - (list names* exps*))) - (_ (list names exp)))) - names exps*)) - ;; If there are no bindings left, remove the 'let' entirely. - (if (null? bindings) - (simplify body env*) - `(let-values ,bindings - ,(simplify body env*)))) - -(define (simplify:primcall op args env) - (let* ((primitive (lookup-seagull-primitive op)) - (proc (seagull-primitive-proc primitive)) - (args* (simplify:list args env))) - (if (and (procedure? proc) (every constant? args*)) - (apply proc args*) - `(primcall ,op ,@args*)))) - -(define (simplify:call operator args env) - `(call ,(simplify operator env) - ,@(simplify:list args env))) - -(define (simplify:struct-ref exp field env) - `(struct-ref ,(simplify exp env) ,field)) - -(define (simplify:array-ref array-exp index-exp env) - `(array-ref ,(simplify array-exp env) - ,(simplify index-exp env))) - -(define (simplify:top-level inputs body env) - `(top-level ,inputs - ,(simplify body env))) - -(define (simplify:outputs names exps env) - `(outputs ,@(map (lambda (name exp) - (list name (simplify exp env))) - names exps))) - -(define (simplify exp env) - (match exp - ((? constant?) exp) - ((? symbol?) - (lookup* exp env exp)) - (('if predicate consequent alternate) - (simplify:if predicate consequent alternate env)) - (('lambda (params ...) body) - (simplify:lambda params body env)) - (('values exps ...) - (simplify:values exps env)) - (('let ((names exps) ...) body) - (simplify:let names exps body env)) - (('let-values ((names exps) ...) body) - (simplify:let-values names exps body env)) - (('primcall operator args ...) - (simplify:primcall operator args env)) - (('call operator args ...) - (simplify:call operator args env)) - (('struct-ref exp field) - (simplify:struct-ref exp field env)) - (('array-ref array-exp index-exp) - (simplify:array-ref array-exp index-exp env)) - (('outputs (names exps) ...) - (simplify:outputs names exps env)) - (('top-level inputs body) - (simplify:top-level inputs body env)))) - -(define (simplify* exp) - (simplify exp (empty-env))) - - -;;; -;;; Dead code elimination -;;; - -;; Find and remove unused variable bindings. Report errors for unused -;; globals, as they will cause problems later when the graphics -;; driver's GLSL compiler eliminates them. This also takes care of -;; what would be an issue later on: If an 'outputs' form is bound to -;; an unused variable, the GLSL emitter would emit global variable -;; mutations even though they shouldn't happen! This is a quirk of -;; 'outputs' being the only form that produces side-effects but dead -;; code elimination takes care of the problem. - -(define &seagull-unused-global-error - (make-exception-type '&seagull-unused-global-error &error '(variable))) - -(define make-seagull-unusued-global-error - (record-constructor &seagull-unused-global-error)) - -(define seagull-unused-global-variable - (exception-accessor &seagull-unused-global-error - (record-accessor &seagull-unused-global-error 'variable))) - -(define (unused-variable? var exp) - (define (unused-in-list? exps) - (every (lambda (exp) (unused-variable? var exp)) exps)) - (match exp - ((? constant?) #t) - ((? symbol?) - (not (eq? exp var))) - (('if predicate consequent alternate) - (and (unused-variable? var predicate) - (unused-variable? var consequent) - (unused-variable? var alternate))) - (('lambda (params ...) body) - (unused-variable? var body)) - (('values exps ...) - (unused-in-list? exps)) - (((or 'let 'let-values) ((names exps) ...) body) - (and (unused-in-list? exps) - (unused-variable? var body))) - (('primcall operator args ...) - (unused-in-list? args)) - (('call operator args ...) - (and (unused-variable? var operator) - (unused-in-list? args))) - (('struct-ref exp field) - (unused-variable? var exp)) - (('array-ref array-exp index-exp) - (and (unused-variable? var array-exp) - (unused-variable? var index-exp))) - (('outputs (names exps) ...) - (and (unused-in-list? names) (unused-in-list? exps))) - (('top-level _ body) - (unused-variable? var body)))) - -(define (prune:list exps) - (map prune exps)) - -(define (prune:if predicate consequent alternate) - `(if ,(prune predicate) - ,(prune consequent) - ,(prune alternate))) - -(define (prune:lambda params body) - `(lambda ,params ,(prune body))) - -(define (prune:values exps) - (prune:list exps)) - -(define (prune:let names exps body) - (define exps* (prune:list exps)) - (define body* (prune body)) - (define bindings - (filter-map (lambda (name exp) - (if (unused-variable? name body*) - #f - (list name exp))) - names exps*)) - ;; Remove 'let' if all bindings are dead. - (if (null? bindings) - body* - `(let ,bindings ,body*))) - -(define (prune:let-values names exps body) - (define bindings - (filter-map (lambda (names exp) - (if (every (lambda (name) - (unused-variable? name body)) - names) - #f - (list names exp))) - names exps)) - ;; Remove 'let' if all bindings are dead. - (if (null? bindings) - (prune body) - `(let-values ,bindings ,(prune body)))) - -(define (prune:primcall operator args) - `(primcall ,operator ,@(prune:list args))) - -(define (prune:call operator args) - `(call ,(prune operator) ,@(prune:list args))) - -(define (prune:struct-ref exp field) - `(struct-ref ,(prune exp) ,field)) - -(define (prune:array-ref array-exp index-exp) - `(array-ref ,(prune array-exp) - ,(prune index-exp))) - -(define (prune:outputs names exps) - `(outputs ,@(map (lambda (name exp) - (list name - (prune exp))) - names exps))) - -(define (prune:top-level qualifiers type-descriptors names body) - (for-each (lambda (qualifier type-desc name) - (when (unused-variable? name body) - (raise-exception - (make-exception - (make-seagull-unusued-global-error name) - (make-exception-with-origin prune:top-level) - (make-exception-with-message - (format #f "seagull: global variable '~a ~a ~a' is unused" - qualifier type-desc name)) - (make-exception-with-irritants (list name)))))) - qualifiers type-descriptors names) - `(top-level ,(map list qualifiers type-descriptors names) - ,(prune body))) - -(define (prune exp) - (match exp - ((or (? constant?) (? symbol?)) - exp) - (('if predicate consequent alternate) - (prune:if predicate consequent alternate)) - (('lambda (params ...) body) - (prune:lambda params body)) - (('values exps ...) - (prune:values exps)) - (('let ((names exps) ...) body) - (prune:let names exps body)) - (('let-values ((names exps) ...) body) - (prune:let-values names exps body)) - (('primcall operator args ...) - (prune:primcall operator args)) - (('call operator args ...) - (prune:call operator args)) - (('struct-ref exp field) - (prune:struct-ref exp field)) - (('array-ref array-exp index-exp) - (prune:array-ref array-exp index-exp)) - (('outputs (names exps) ...) - (prune:outputs names exps)) - (('top-level ((qualifiers type-descs names) ...) body) - (prune:top-level qualifiers type-descs names body)))) - - -;;; -;;; Function hoisting -;;; - -;; Move all lambda bindings to the top-level. Unfortunately, GLSL -;; does not allow nested function definitions, so nested functions in -;; Seagull only allow free variable references for top-level -;; variables, such as shader inputs and uniforms. - -(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 (check-free-variables-in-list exps bound-vars top-level-vars) - (every (lambda (exp) - (check-free-variables exp bound-vars top-level-vars)) - exps)) - -(define (check-free-variables exp bound-vars top-level-vars) - (match exp - ((? constant?) - #t) - ((? symbol?) - (or (memq exp bound-vars) ; bound vars: OK - (memq exp top-level-vars) ; top-level vars: OK - ;; Free variables that aren't top-level are not allowed because - ;; GLSL doesn't support closures. - (raise-exception - (make-exception - (make-seagull-scope-error exp) - (make-exception-with-origin check-free-variables) - (make-exception-with-message - "seagull: free variable is not top-level") - (make-exception-with-irritants (list exp)))))) - (('if predicate consequent alternate) - (and (check-free-variables predicate bound-vars top-level-vars) - (check-free-variables consequent bound-vars top-level-vars) - (check-free-variables alternate bound-vars top-level-vars))) - (('let ((names exps) ...) body) - (define bound-vars* (append names bound-vars)) - (and (check-free-variables-in-list exps bound-vars* top-level-vars) - (check-free-variables body bound-vars* top-level-vars))) - (('let-values ((names exps) ...) body) - (define bound-vars* (append (concatenate names) bound-vars)) - (and (check-free-variables-in-list exps bound-vars* top-level-vars) - (check-free-variables body bound-vars* top-level-vars))) - (('lambda (params ...) body) - (check-free-variables body params top-level-vars)) - (('values exps ...) - (check-free-variables-in-list exps bound-vars top-level-vars)) - ((or ('primcall _ args ...) - ('call args ...)) - (check-free-variables-in-list args bound-vars top-level-vars)) - (('struct-ref exp _) - (check-free-variables exp bound-vars top-level-vars)) - (('array-ref array-exp index-exp) - (and (check-free-variables array-exp bound-vars top-level-vars) - (check-free-variables index-exp bound-vars top-level-vars))) - (('outputs (names exps) ...) - (check-free-variables-in-list exps bound-vars top-level-vars)) - (('top-level ((_ _ names) ...) body) - (define bound-vars* (append names bound-vars)) - (check-free-variables body bound-vars* top-level-vars)))) - -(define (hoist:list exps) - (let-values (((exp-list env-list) - (unzip2 - (map (lambda (exp) - (call-with-values - (lambda () - (hoist-functions exp)) - list)) - exps)))) - (values exp-list (apply compose-envs env-list)))) - -(define (hoist:if predicate consequent alternate) - (define-values (predicate* predicate-env) - (hoist-functions predicate)) - (define-values (consequent* consequent-env) - (hoist-functions consequent)) - (define-values (alternate* alternate-env) - (hoist-functions alternate)) - (values `(if ,predicate* ,consequent* ,alternate*) - (compose-envs predicate-env consequent-env alternate-env))) - -(define (hoist:let names exps body) - (define-values (exps* exps-env) - (hoist:list exps)) - (define-values (body* body-env) - (hoist-functions body)) - ;; Remove all lambda bindings... - (define bindings - (filter-map (lambda (name exp) - (match exp - (('lambda _ _) - #f) - (_ (list name exp)))) - names exps*)) - ;; ...and add them to the top-level environment. - (define env* - (fold (lambda (name exp env) - (match exp - (('lambda _ _) - (extend-env name exp env)) - (_ env))) - (compose-envs exps-env body-env) - names exps*)) - ;; If there are no bindings left, remove the 'let'. - (values (if (null? bindings) - body* - `(let ,bindings ,body*)) - env*)) - -(define (hoist:let-values names exps body) - (define-values (exps* exps-env) - (hoist:list exps)) - (define-values (body* body-env) - (hoist-functions body)) - ;; Remove all lambda bindings... - (define bindings - (filter-map (lambda (names exp) - (match names - ((name) - (match exp - (('lambda _ _) - #f) - (_ (list (list name) exp)))) - (_ - (list names exp)))) - names exps*)) - ;; ...and add them to the top-level environment. - (define env* - (fold (lambda (name exp env) - (match names - ((name) - (match exp - (('lambda _ _) - (extend-env name exp env)) - (_ env))) - (_ env))) - (compose-envs exps-env body-env) - names exps*)) - ;; If there are no bindings left, remove the 'let-values'. - (values (if (null? bindings) - body* - `(let-values ,bindings ,body*)) - env*)) - -(define (hoist:lambda params body) - (define-values (body* body-env) - (hoist-functions body)) - (values `(lambda ,params ,body*) body-env)) - -(define (hoist:values exps) - (define-values (exps* exp-env) - (hoist:list exps)) - (values `(values ,@exps*) exp-env)) - -(define (hoist:primcall operator args) - (define-values (args* args-env) (hoist:list args)) - (values `(primcall ,operator ,@args*) args-env)) - -(define (hoist:call args) - (define-values (args* args-env) (hoist:list args)) - (values `(call ,@args*) args-env)) - -(define (hoist:struct-ref exp field) - (define-values (exp* exp-env) (hoist-functions exp)) - (values `(struct-ref ,exp* ,field) exp-env)) - -(define (hoist:array-ref array-exp index-exp) - (define-values (array-exp* array-exp-env) - (hoist-functions array-exp)) - (define-values (index-exp* index-exp-env) - (hoist-functions index-exp)) - (values `(array-ref ,array-exp* ,index-exp*) - (compose-envs array-exp-env index-exp-env))) - -(define (hoist:top-level inputs body) - (define-values (body* body-env) - (hoist-functions body)) - (values `(top-level ,inputs ,body*) - body-env)) - -(define (hoist:outputs names exps) - (define-values (exps* exp-env) - (hoist:list exps)) - (values `(outputs - ,@(map (lambda (name exp) - (list name exp)) - names exps*)) - exp-env)) - -(define (hoist-functions exp) - (match exp - ((or (? constant?) (? symbol?)) - (values exp (empty-env))) - (('if predicate consequent alternate) - (hoist:if predicate consequent alternate)) - (('let ((names exps) ...) body) - (hoist:let names exps body)) - (('let-values ((names exps) ...) body) - (hoist:let-values names exps body)) - (('lambda (params ...) body) - (hoist:lambda params body)) - (('values exps ...) - (hoist:values exps)) - (('primcall operator args ...) - (hoist:primcall operator args)) - (('call args ...) - (hoist:call args)) - (('struct-ref exp member) - (hoist:struct-ref exp member)) - (('array-ref array-exp index-exp) - (hoist:array-ref array-exp index-exp)) - (('outputs (names exps) ...) - (hoist:outputs names exps)) - (('top-level inputs body) - (hoist:top-level inputs body)))) - -(define (maybe-merge-top-levels new-bindings exp) - (match exp - (('top-level bindings body) - `(top-level ,(append bindings new-bindings) ,body)) - (_ - `(top-level ,new-bindings ,exp)))) - -(define (hoist-functions* exp) - (define-values (exp* function-env) - (hoist-functions exp)) - (define top-level-vars - (append (env-names function-env) - (map (match-lambda - ((_ _ name) name)) - (match exp* - (('top-level bindings _) - bindings) - (_ '()))))) - (env-for-each (lambda (name exp) - (check-free-variables exp '() top-level-vars)) - function-env) - (define bindings - (env-map (lambda (name func) - `(function ,name ,func)) - function-env)) - (maybe-merge-top-levels bindings exp*)) - - -;;; -;;; Type inference -;;; - -;; Walk the expression tree of a type annotated program and solve for -;; all of the type variables using a variant of the Hindley-Milner -;; type inference algorithm extended to handle qualified types (types -;; with predicates.) GLSL is a statically typed language, but thanks -;; to type inference the user doesn't have to specify any types expect -;; for shader inputs, outputs, and uniforms. - -(define &seagull-type-error - (make-exception-type '&seagull-type-error &error '())) - -(define make-seagull-type-error - (record-constructor &seagull-type-error)) - -(define (seagull-type-error msg args origin) - (raise-exception - (make-exception - (make-seagull-type-error) - (make-exception-with-origin origin) - (make-exception-with-message - (format #f "seagull type error: ~a" msg)) - (make-exception-with-irritants args)))) - -(define (type-mismatch a b origin) - (seagull-type-error "type mismatch" (list a b) origin)) - -(define (type-descriptor->type desc) - (match desc - ((? symbol?) - (lookup-type desc)) - (('array desc* (? exact-integer? length) (? exact-integer? rest) ...) - (let loop ((rest rest) - (prev (array-type (type-descriptor->type desc*) length))) - (match rest - (() prev) - ((length . rest) - (loop rest (array-type prev length)))))))) - -(define (apply-substitution-to-type type from to) - (cond - ((or (primitive-type? type) - (struct-type? type) - (outputs-type? type)) - type) - ((variable-type? type) - (if (equal? type from) to type)) - ((function-type? type) - (function-type - (map (lambda (param-type) - (apply-substitution-to-type param-type from to)) - (function-type-parameters type)) - (map (lambda (return-type) - (apply-substitution-to-type return-type from to)) - (function-type-returns type)))) - ((array-type? type) - (array-type (apply-substitution-to-type (array-type-ref type) from to) - (array-type-length type))) - ((type-scheme? type) - type) - (else - (seagull-type-error "invalid type" - (list type) - apply-substitution-to-type)))) - -(define (apply-substitutions-to-type type subs) - (env-fold (lambda (from to type*) - (apply-substitution-to-type type* from to)) - type - subs)) - -(define (apply-substitutions-to-types types subs) - (map (lambda (type) - (apply-substitutions-to-type type subs)) - types)) - -(define (apply-substitution-to-env env from to) - (env-fold (lambda (name type env*) - (extend-env name - (apply-substitution-to-type type from to) - env*)) - (empty-env) - env)) - -(define (apply-substitutions-to-env env subs) - (env-fold (lambda (from to env*) - (apply-substitution-to-env env* from to)) - env - subs)) - -(define (apply-substitutions-to-texp t subs) - (texp (apply-substitutions-to-types (texp-types t) subs) - (texp-exp t))) - -(define (apply-substitutions-to-exp exp subs) - (match exp - ((? type?) - (apply-substitutions-to-type exp subs)) - ((exps ...) - (map (lambda (exp) - (apply-substitutions-to-exp exp subs)) - exps)) - (_ exp))) - -;; Typed expressions: -(define (texp types exp) - `(t ,types ,exp)) - -(define (texp? obj) - (match obj - (('t _ _) #t) - (_ #f))) - -(define (texp-types texp) - (match texp - (('t types _) types))) - -(define (texp-exp texp) - (match texp - (('t _ exp) exp))) - -(define (single-type texp) - (match (texp-types texp) - ((type) type) - (_ (seagull-type-error "expected single type expression" - (list texp) - single-type)))) - -(define (occurs? a b) - (cond - ((and (variable-type? a) (variable-type? b)) - (eq? a b)) - ((and (variable-type? a) (function-type? b)) - (or (occurs? a (function-type-parameters b)) - (occurs? a (function-type-returns b)))) - ((and (type? a) (list? b)) - (any (lambda (b*) (occurs? a b*)) b)) - (else #f))) - -(define (compose-substitutions a b) - (define b* - (map (match-lambda - ((from . to) - (cons from (apply-substitutions-to-type to a)))) - b)) - (define a* - (filter-map (match-lambda - ((from . to) - (if (assq-ref b* from) - #f - (cons from to)))) - a)) - (append a* b*)) - -(define* (free-variables-in-type type) - (cond - ((or (primitive-type? type) - (struct-type? type)) - '()) - ((array-type? type) - (free-variables-in-type (array-type-ref type))) - ((variable-type? type) (list type)) - ((function-type? type) - (let ((params (function-type-parameters type))) - (filter (lambda (t) (member t params)) - (delete-duplicates - (append-map free-variables-in-type - (function-type-returns type)))))) - ((type-scheme? type) - (fold delete - (free-variables-in-type (type-scheme-ref type)) - (type-scheme-quantifiers type))) - (else - (seagull-type-error "unknown type" - (list type) - free-variables-in-type)))) - -(define (difference a b) - (match a - (() b) - ((x . rest) - (if (memq x b) - (difference rest (delq x b)) - (cons x (difference rest b)))))) - -(define (free-variables-in-type-scheme type-scheme) - (difference (type-scheme-quantifiers type-scheme) - (free-variables-in-type (type-scheme-ref type-scheme)))) - -(define (free-variables-in-env env) - (delete-duplicates - (env-fold (lambda (_name type vars) - (cond - ((variable-type? type) - (cons (free-variables-in-type type) - vars)) - ((type-scheme? type) - (cons (free-variables-in-type-scheme type) - vars)) - (else vars))) - '() - env))) - -(define (free-variables-in-predicate pred) - (match pred - ((or #t #f) '()) - (((or '= 'substitute) a b) - (append (free-variables-in-type a) - (free-variables-in-type b))) - (((or 'and 'or 'compose) a b) - (append (free-variables-in-predicate a) - (free-variables-in-predicate b))) - (('struct-field struct field var) - (append (free-variables-in-type struct) - (free-variables-in-type var))) - (('array-element array var) - (append (free-variables-in-type array) - (free-variables-in-type var))))) - -;; Quantified variables are type variables that appear free in the -;; function return types or in the predicate. -(define (generalize type pred env) - (if (function-type? type) - (match (difference (delete-duplicates - (append (free-variables-in-type type) - (free-variables-in-predicate - (type-predicate-exp pred)))) - (free-variables-in-env env)) - (() type) - ((quantifiers ...) - (type-scheme quantifiers (qualified-type type pred)))) - type)) - -(define (instantiate type-scheme) - (define subs - (fold (lambda (var env) - (extend-env var (fresh-variable-type) env)) - (empty-env) - (type-scheme-quantifiers type-scheme))) - (define type (type-scheme-ref type-scheme)) - (values - (apply-substitutions-to-type (if (qualified-type? type) - (qualified-type-ref type) - type) - subs) - (if (qualified-type? type) - (apply-substitutions-to-predicate (qualified-type-predicate type) - subs) - predicate:succeed))) - -(define (maybe-instantiate type) - (if (type-scheme? type) - (instantiate type) - (values type predicate:succeed))) - -(define (unify:primitives a b) - (if (equal? a b) - '() - (type-mismatch a b unify:primitives))) - -(define (unify:structs a b) - (if (equal? a b) - '() - (type-mismatch a b unify:structs))) - -(define (unify:variable a b) - (cond - ((eq? a b) - '()) - ((occurs? a b) - (seagull-type-error "circular type" (list a b) unify:variable)) - (else - (list (cons a b))))) - -(define (unify:functions a b) - (define param-subs - (unify (function-type-parameters a) - (function-type-parameters b))) - (define return-subs - (unify (apply-substitutions-to-types (function-type-returns a) - param-subs) - (apply-substitutions-to-types (function-type-returns b) - param-subs))) - (compose-substitutions param-subs return-subs)) - -(define (unify:lists a rest-a b rest-b) - (define sub-first (unify a b)) - (define sub-rest - (unify (apply-substitutions-to-types rest-a sub-first) - (apply-substitutions-to-types rest-b sub-first))) - (compose-substitutions sub-first sub-rest)) - -(define (unify a b) - (match (list a b) - (((? primitive-type? a) (? primitive-type? b)) - (unify:primitives a b)) - (((? struct-type? a) (? struct-type? b)) - (unify:structs a b)) - ((or ((? variable-type? a) b) - (b (? variable-type? a))) - (unify:variable a b)) - (((? function-type? a) (? function-type? b)) - (unify:functions a b)) - (((? outputs-type?) (? outputs-type?)) - '()) - (((? type?) (? type?)) - (type-mismatch a b unify)) - ((() ()) - '()) - (((a rest-a ...) (b rest-b ...)) - (unify:lists a rest-a b rest-b)) - (_ - (type-mismatch a b unify)))) - -(define (infer:constant x) - (values (texp (list (cond - ((exact-integer? x) - type:int) - ((float? x) - type:float) - ((boolean? x) - type:bool))) - x) - '() - predicate:succeed)) - -(define (infer:variable name env) - (define-values (type pred) - (maybe-instantiate (lookup name env))) - (values (texp (list type) name) - '() - pred)) - -(define (infer:list exps env) - (let loop ((exps exps) - (texps '()) - (subs '()) - (pred predicate:succeed)) - (match exps - (() - (values (reverse texps) subs pred)) - ((exp . rest) - (define-values (texp subs* pred*) - (infer exp env)) - (define-values (new-pred combined-subs) - (eval-predicate* (predicate:compose pred pred*) - (compose-substitutions subs subs*))) - (loop rest - (cons texp texps) - combined-subs - new-pred))))) - -(define (infer:if predicate consequent alternate env) - ;; Infer predicate types and unify it with the boolean type. - (define-values (predicate-texp predicate-subs predicate-pred) - (infer predicate env)) - (define predicate-unify-subs - (unify (texp-types predicate-texp) (list type:bool))) - ;; Combine the substitutions and apply them to the environment. - (define combined-subs-0 - (compose-substitutions predicate-subs predicate-unify-subs)) - (define env0 - (apply-substitutions-to-env env combined-subs-0)) - ;; Infer consequent and alternate types and unify them against each - ;; other. Each branch of an 'if' should have the same type. - (define-values (consequent-texp consequent-subs consequent-pred) - (infer consequent env0)) - (define combined-subs-1 - (compose-substitutions combined-subs-0 consequent-subs)) - (define env1 - (apply-substitutions-to-env env0 consequent-subs)) - (define-values (alternate-texp alternate-subs alternate-pred) - (infer alternate env1)) - (define combined-subs-2 - (compose-substitutions combined-subs-1 alternate-subs)) - ;; Eval combined predicate. - (define-values (pred combined-subs-3) - (eval-predicate* (predicate:compose predicate-pred - consequent-pred - alternate-pred) - combined-subs-2)) - ;; ;; Apply final set of substitutions to the types of both branches. - (define consequent-texp* - (apply-substitutions-to-texp consequent-texp combined-subs-3)) - (define alternate-texp* - (apply-substitutions-to-texp alternate-texp combined-subs-3)) - (values (texp (texp-types consequent-texp) - `(if ,predicate-texp ,consequent-texp ,alternate-texp)) - combined-subs-3 - pred)) - -(define (infer:lambda params body env) - ;; Each function parameter gets a fresh type variable. - (define param-types (fresh-variable-types-for-list params)) - ;; The type environment is extended with the function parameters. - (define env* - (fold (lambda (param type env*) - (extend-env param type env*)) - env params param-types)) - (define-values (body* body-subs body-pred) - (infer body env*)) - (define-values (pred subs) - (eval-predicate* body-pred body-subs)) - (values (texp (list (generalize - (function-type (apply-substitutions-to-types param-types - subs) - (texp-types body*)) - pred env)) - `(lambda ,params ,body*)) - subs predicate:succeed)) - -(define (check-arity type arity) - (define (arity-error) - (seagull-type-error "wrong number of arguments" - (list type arity) check-arity)) - (cond - ((function-type? type) - (if (= (length (function-type-parameters type)) arity) - type - (arity-error))) - ((function-case-type? type) - (let ((function (function-case-type-ref type arity))) - (or function (arity-error)))) - ;; TODO: We aren't actually checking arity here. - ((type-scheme? type) - type) - ((type? type) - (seagull-type-error "expected a function" (list type) check-arity)))) - -(define (infer:primitive-call operator args env) - (define primitive (lookup-seagull-primitive operator)) - ;; Primitive functions may be overloaded and need to be instantiated - ;; with fresh type variables. - (define-values (operator-type operator-pred) - (maybe-instantiate - (check-arity (seagull-primitive-type primitive) - (length args)))) - ;; Infer the arguments. - (define-values (args* arg-subs arg-pred) - (infer:list args env)) - ;; Generate fresh type variables to unify against the return types - ;; of the operator. - (define return-vars - (fresh-variable-types-for-list (function-type-returns operator-type))) - (define call-subs - (unify operator-type - (function-type (map single-type args*) - return-vars))) - ;; Apply substitutions to the predicate and then eval it, producing - ;; a simplified predicate and a set of substitutions. - (define-values (pred combined-subs) - (eval-predicate* (predicate:compose operator-pred arg-pred) - (compose-substitutions arg-subs call-subs))) - (values (texp (apply-substitutions-to-types return-vars combined-subs) - `(primcall ,operator - ,@(map (lambda (arg) - (apply-substitutions-to-texp arg - combined-subs)) - args*))) - combined-subs - pred)) - -(define (infer:call operator args env) - ;; The type signature of primitive functions can be looked up - ;; directly in the environment. - (define-values (operator* operator-subs operator-pred) - (infer operator env)) - (define env* - (apply-substitutions-to-env env operator-subs)) - ;; Infer the arguments. - (define-values (args* arg-subs arg-pred) - (infer:list args env*)) - (define combined-subs-0 - (compose-substitutions operator-subs arg-subs)) - ;; Generate fresh type variables to unify against the return types - ;; of the operator. - (define operator-type (single-type operator*)) - (define return-vars - (fresh-variable-types-for-list - (function-type-returns operator-type))) - (define call-subs - (unify (apply-substitutions-to-type operator-type combined-subs-0) - (function-type (apply-substitutions-to-types (map single-type args*) - combined-subs-0) - return-vars))) - ;; Eval predicate. - (define-values (pred combined-subs) - (eval-predicate* (predicate:compose operator-pred - arg-pred) - (compose-substitutions combined-subs-0 call-subs))) - (values (texp (apply-substitutions-to-types return-vars combined-subs) - `(call ,(apply-substitutions-to-texp operator* combined-subs) - ,@(map (lambda (arg) - (apply-substitutions-to-texp arg - combined-subs)) - args*))) - combined-subs - pred)) - -(define (infer:struct-ref exp field env) - (define-values (exp* exp-subs exp-pred) - (infer exp env)) - (define exp-type (single-type exp*)) - (define tvar (fresh-variable-type)) - (define-values (pred combined-subs) - (eval-predicate* (predicate:compose (predicate:struct-field exp-type field tvar) - exp-pred) - exp-subs)) - (values (texp (list (apply-substitutions-to-type tvar combined-subs)) - `(struct-ref ,(apply-substitutions-to-texp exp* combined-subs) - ,field)) - combined-subs - pred)) - -(define (infer:array-ref array-exp index-exp env) - (define-values (array-exp* array-exp-subs array-exp-pred) - (infer array-exp env)) - (define array-type (single-type array-exp*)) - (define env* (apply-substitutions-to-env env array-exp-subs)) - (define-values (index-exp* index-exp-subs index-exp-pred) - (infer index-exp env*)) - (define index-type (single-type index-exp*)) - (define combined-subs - (compose-substitutions array-exp-subs index-exp-subs)) - ;; Array indices must be integers. - (define unify-subs - (unify (apply-substitutions-to-type index-type combined-subs) type:int)) - (define tvar (fresh-variable-type)) - (define-values (pred subs) - (eval-predicate* (predicate:compose (predicate:array-element array-type tvar) - array-exp-pred - index-exp-pred) - (compose-substitutions combined-subs unify-subs))) - (define array-exp** - (apply-substitutions-to-texp array-exp* subs)) - (define index-exp** - (apply-substitutions-to-texp index-exp* subs)) - (values (texp (list tvar) - `(array-ref ,array-exp** ,index-exp**)) - subs - pred)) - -(define (infer:let names exps body env) - (define-values (exps* exp-subs exp-pred) - (infer:list exps env)) - (define exp-types (map single-type exps*)) - (define env* - (fold extend-env - (apply-substitutions-to-env env exp-subs) - names - exp-types)) - (define-values (body* body-subs body-pred) - (infer body env*)) - (define-values (pred combined-subs) - (eval-predicate* (predicate:compose exp-pred body-pred) - (compose-substitutions exp-subs body-subs))) - (define bindings - (map (lambda (name exp) - (let ((num-types (length (texp-types exp)))) - (unless (= num-types 1) - (seagull-type-error (format #f "expected 1 value, got ~a" - num-types) - (list name exp) - infer:let)) - (list name (apply-substitutions-to-texp exp combined-subs)))) - names exps*)) - (values (texp (texp-types body*) - `(let ,bindings - ,(apply-substitutions-to-texp body* combined-subs))) - combined-subs - pred)) - -(define (infer:let-values names exps body env) - (define-values (exps* exp-subs exp-pred) - (infer:list exps env)) - (define exp-types (map texp-types exps*)) - (define env* - (fold (lambda (names types env) - (fold extend-env env names types)) - (apply-substitutions-to-env env exp-subs) - names - exp-types)) - (define-values (body* body-subs body-pred) - (infer body env*)) - (define-values (pred combined-subs) - (eval-predicate* (predicate:compose exp-pred body-pred) - (compose-substitutions exp-subs body-subs))) - (define bindings - (map (lambda (names exp) - (let ((num-names (length names)) - (num-types (length (texp-types exp)))) - (unless (= num-names num-types) - (seagull-type-error (format #f "expected ~a ~a, got ~a" - num-names - (if (= num-names 1) "value" "values") - num-types) - (list names exp) - infer:let-values)) - (list names - (apply-substitutions-to-texp exp combined-subs)))) - names exps*)) - (values (texp (texp-types body*) - `(let-values ,bindings - ,(apply-substitutions-to-texp body* combined-subs))) - combined-subs - pred)) - -(define (infer:values exps env) - (define-values (exps* exp-subs exp-pred) - (infer:list exps env)) - (values (texp (map single-type exps*) - `(values ,@exps*)) - exp-subs - exp-pred)) - -(define (infer:outputs names exps env) - (define-values (exps* exp-subs exp-pred) - (infer:list exps env)) - (define unify-subs - (unify (map single-type exps*) - (map (lambda (name) - (lookup name env)) - names))) - ;; Eval predicate. - (define-values (pred combined-subs) - (eval-predicate* exp-pred (compose-substitutions exp-subs unify-subs))) - (values (texp (list type:outputs) - `(outputs - ,@(map (lambda (name exp) - (list name (apply-substitutions-to-texp - exp combined-subs))) - names exps*))) - combined-subs - pred)) - -(define (infer:top-level bindings body env) - (define (infer-bindings bindings texps subs pred env) - (match bindings - (() - (values (reverse texps) subs pred env)) - ((('function name exp) . rest) - (define-values (texp subs* pred*) - (infer exp env)) - (define-values (new-pred combined-subs) - (eval-predicate* (predicate:compose pred pred*) - (compose-substitutions subs subs*))) - (define env* - (apply-substitutions-to-env (extend-env name (single-type texp) env) - combined-subs)) - (infer-bindings rest - (cons texp texps) - combined-subs - new-pred - env*)) - (((_ desc name) . rest) - (define type (type-descriptor->type desc)) - (infer-bindings rest - (cons (list type) texps) - subs - pred - (extend-env name type env))))) - (define qualifiers (map first bindings)) - (define names - (map (match-lambda - (('function name _) name) - ((_ _ name) name)) - bindings)) - (define type-names - (map (match-lambda - (((? top-level-qualifier?) type-name _) type-name) - (_ #f)) - bindings)) - (define-values (exps exp-subs exp-pred env*) - (infer-bindings bindings '() '() predicate:succeed env)) - (define-values (body* body-subs body-pred) - (infer body env*)) - (define-values (pred combined-subs) - (eval-predicate* (predicate:compose exp-pred body-pred) - (compose-substitutions exp-subs body-subs))) - (define bindings* - (map (match-lambda* - (((? top-level-qualifier? qualifier) type-name name _) - (list qualifier type-name name)) - (('function _ name exp) - `(function ,name ,(apply-substitutions-to-exp exp combined-subs)))) - qualifiers type-names names exps)) - (values (texp (texp-types body*) - `(top-level ,bindings* ,body*)) - combined-subs - pred)) - -;; Inference returns 3 values: -;; - a typed expression -;; - a list of substitutions -;; - a type predicate -(define (infer exp env) - (match exp - ((? constant?) - (infer:constant exp)) - ((? symbol? name) - (infer:variable name env)) - (('if predicate consequent alternate) - (infer:if predicate consequent alternate env)) - (('let ((names exps) ...) body) - (infer:let names exps body env)) - (('let-values ((names exps) ...) body) - (infer:let-values names exps body env)) - (('lambda (params ...) body) - (infer:lambda params body env)) - (('values exps ...) - (infer:values exps env)) - (('primcall operator args ...) - (infer:primitive-call operator args env)) - (('call operator args ...) - (infer:call operator args env)) - (('struct-ref exp field) - (infer:struct-ref exp field env)) - (('array-ref array-exp index-exp) - (infer:array-ref array-exp index-exp env)) - (('outputs (names exps) ...) - (infer:outputs names exps env)) - (('top-level bindings body) - (infer:top-level bindings body env)) - ;; User code shouldn't trigger this, only us screwing up an - ;; earlier compiler pass. - (_ (error "unknown form" exp)))) - -(define (infer:top-level-env stage) - (fold (lambda (v env) - (let ((name (seagull-variable-name v)) - (type (seagull-variable-type v))) - (extend-env name type env))) - (empty-env) - (find-variables - (lambda (v) - (variable-for-stage? v stage))))) - -;; TODO: Add some kind of context object that is threaded through the -;; inference process so that when a type error occurs we can show the -;; expression that caused it. -(define (infer* exp stage) - (infer exp (infer:top-level-env stage))) - - -;;; -;;; Overloaded functions -;;; - -;; Replace quantified functions ('type-scheme' expressions) with a series -;; of non-quantified function type specifications, one for each unique -;; type of call in the program. - -(define (find-signatures:list name texps) - (append-map (lambda (texp) - (find-signatures name texp)) - texps)) - -(define (find-signatures:if name predicate consequent alternate) - (append (find-signatures name predicate) - (find-signatures name consequent) - (find-signatures name alternate))) - -(define (find-signatures:let name binding-texps body) - (append (find-signatures:list name binding-texps) - (find-signatures name body))) - -(define (find-signatures:array-ref name array index) - (append (find-signatures name array) - (find-signatures name index))) - -(define (find-signatures name texp) - (match (texp-exp texp) - ((or (? constant?) (? symbol?)) - '()) - (('if predicate consequent alternate) - (find-signatures:if name predicate consequent alternate)) - (('let ((_ exps) ...) body) - (find-signatures:let name exps body)) - (('values exps ...) - (find-signatures:list name exps)) - (('primcall _ args ...) - (find-signatures:list name args)) - (('call operator args ...) - (cons (if (eq? (texp-exp operator) name) - (function-type (map single-type args) - (texp-types texp))) - (find-signatures:list name args))) - (('struct-ref struct _) - (find-signatures name struct)) - (('array-ref array index) - (find-signatures:array-ref name array index)) - (('outputs (_ exps) ...) - (find-signatures:list name exps)))) - -(define (vars->subs exp env) - (match exp - (('t ((? variable-type? tvar)) (? symbol? name)) - (let ((type (lookup* name env))) - (if type - (list (cons tvar type)) - '()))) - ((head . rest) - (delete-duplicates - (append (vars->subs head env) - (vars->subs rest env)))) - (_ '()))) - -(define (untype x) - (match x - (('t (_ ...) exp) - (untype exp)) - ((exp . rest) - (cons (untype exp) (untype rest))) - (_ x))) - -(define (resolve-overloads program stage) - ;; Find all of the struct types used in the program. They will be - ;; used to generate overloaded functions that take one or more - ;; structs as arguments. - ;;(define structs (delete-duplicates (find-structs program))) - (match program - (('t types ('top-level bindings body)) - (define bindings* - (let loop ((bindings bindings) - (globals (empty-env))) - (match bindings - (() '()) - ((('function name ('t ((? type-scheme? type)) func)) . rest) - (define qtype (type-scheme-ref type)) - (define func-type (qualified-type-ref qtype)) - (append (map (lambda (call-type) - (define subs - (unify func-type call-type)) - (define type* - (apply-substitutions-to-type func-type subs)) - (define params - (match func - (('lambda (params ...) _) - params))) - (define env - (compose-envs (fold extend-env - (empty-env) - params - (function-type-parameters - type*)) - globals)) - (match func - (('lambda _ body) - (let ((top (infer:top-level-env stage))) - (infer (untype body) - (compose-envs env top))))) - (define subs* - (compose-substitutions subs (vars->subs func env))) - (define func* - (apply-substitutions-to-exp func subs*)) - `(function ,name (t (,type*) ,func*))) - (delete-duplicates - (find-signatures name body))) - (loop rest globals))) - ((('function name texp) . rest) - (cons `(function ,name ,texp) - (loop rest globals))) - (((qualifier type name) . rest) - (cons (list qualifier type name) - (loop rest - (extend-env name - (type-descriptor->type type) - globals))))))) - `(t ,types (top-level ,bindings* ,body))))) - - -;;; -;;; GLSL emission -;;; - -;; Transform a fully typed Seagull program into a string of GLSL code. - -(define (type-descriptor->glsl desc) - (match desc - ((? symbol?) - (match (lookup-type desc) - ((? primitive-type? primitive) - (primitive-type-glsl-name primitive)) - ((? struct-type? struct) - (struct-type-glsl-name struct)))) - (('array desc* length) - (format #f "~a[~a]" - (type-descriptor->glsl desc*) - length)))) - -(define (type->glsl type) - (cond - ((primitive-type? type) - (primitive-type-glsl-name type)) - ((struct-type? type) - (struct-type-glsl-name type)) - ((array-type? type) - (format #f "~a[~a]" - (type->glsl (array-type-ref type)) - length)))) - -(define (single-temp temps) - (match temps - ((temp) temp))) - -(define (indent n port) - (when (> n 0) - (display (make-string (* n 2) #\space) port))) - -(define (emit:int n stage version port level) - (define temp (unique-identifier)) - (indent level port) - (format port "int ~a = ~a;\n" temp n) - (list temp)) - -(define (emit:float n stage version port level) - (define temp (unique-identifier)) - (indent level port) - (format port "float ~a = ~a;\n" temp - (if (inf? n) "1.0 / 0.0" n)) - (list temp)) - -(define (emit:boolean b stage version port level) - (define temp (unique-identifier)) - (indent level port) - (format port "bool ~a = ~a;\n" temp (if b "true" "false")) - (list temp)) - -(define (emit:declaration type lhs rhs port level) - (unless (outputs-type? type) - (indent level port) - (if rhs - (format port "~a ~a = ~a;\n" (type->glsl type) lhs rhs) - (format port "~a ~a;\n" (type->glsl type) lhs)))) - -(define (emit:declarations types lhs-list rhs-list port level) - (define rhs-list* (if rhs-list rhs-list (make-list (length lhs-list) #f))) - (for-each (lambda (type lhs rhs) - (emit:declaration type lhs rhs port level)) - types lhs-list rhs-list*)) - -(define (emit:mov a b port level) - (when a - (indent level port) - (format port "~a = ~a;\n" a b))) - -(define (emit:function name type params body stage version port level) - (define param-types (function-type-parameters type)) - (define return-types (function-type-returns type)) - (define outputs (unique-identifiers-for-list return-types)) - (indent level port) - (format port "void ~a(" name) - (let loop ((params (append (zip (make-list (length params) 'in) - param-types - params) - (zip (make-list (length return-types) 'out) - return-types - outputs))) - (first? #t)) - (match params - (() #t) - (((qualifier type name) . rest) - (unless first? - (display ", " port)) - (format port "~a ~a ~a" - qualifier (type->glsl type) name) - (loop rest #f)))) - (display ") {\n" port) - (define body-temps (emit-glsl body stage version port (+ level 1))) - (for-each (lambda (output temp) - (emit:mov output temp port (+ level 1))) - outputs body-temps) - (indent level port) - (display "}\n" port)) - -(define (emit:if predicate consequent alternate stage version port level) - (define if-temps - (if (equal? (texp-types consequent) (list type:outputs)) - '(#f) - (unique-identifiers-for-list (texp-types consequent)))) - (emit:declarations (texp-types consequent) if-temps #f port level) - (define predicate-temp - (single-temp (emit-glsl predicate stage version port level))) - (indent level port) - (format port "if(~a) {\n" predicate-temp) - (define consequent-temps - (emit-glsl consequent stage version port (+ level 1))) - (for-each (lambda (lhs rhs) - (emit:mov lhs rhs port (+ level 1))) - if-temps consequent-temps) - (indent level port) - (display "} else {\n" port) - (define alternate-temps - (emit-glsl alternate stage version port (+ level 1))) - (for-each (lambda (lhs rhs) - (emit:mov lhs rhs port (+ level 1))) - if-temps alternate-temps) - (indent level port) - (display "}\n" port) - if-temps) - -(define (emit:values exps stage version port level) - (append-map (lambda (exp) - (emit-glsl exp stage version port level)) - exps)) - -(define (emit:let types names exps body stage version port level) - (define binding-temps - (map (lambda (exp) - (single-temp (emit-glsl exp stage version port level))) - exps)) - (define binding-types (map single-type exps)) - (emit:declarations binding-types names binding-temps port level) - (define body-temps (emit-glsl body stage version port level)) - (define let-temps (unique-identifiers-for-list types)) - (emit:declarations (texp-types body) let-temps body-temps port level) - let-temps) - -(define (emit:let-values types names exps body stage version port level) - (define names* (concatenate names)) - (define binding-temps - (append-map (lambda (exp) - (emit-glsl exp stage version port level)) - exps)) - (define binding-types (append-map texp-types exps)) - (emit:declarations binding-types names* binding-temps port level) - (define body-temps (emit-glsl body stage version port level)) - (define let-temps (unique-identifiers-for-list types)) - (emit:declarations (texp-types body) let-temps body-temps port level) - let-temps) - -(define (emit:primcall type operator args stage version port level) - (define primitive (lookup-seagull-primitive operator)) - (define operator* (seagull-primitive-glsl-name primitive)) - (define arg-temps - (map (lambda (arg) - (single-temp (emit-glsl arg stage version port level))) - args)) - (define output-temp (unique-identifier)) - (indent level port) - (format port "~a ~a = " - (type->glsl type) - output-temp) - ((seagull-primitive-emit primitive) arg-temps port) - (format port ";\n") - (list output-temp)) - -(define (emit:call types operator args stage version port level) - (define operator-name (single-temp (emit-glsl operator stage version port))) - (define arg-temps - (map (lambda (arg) - (single-temp (emit-glsl arg stage version port level))) - args)) - (define output-temps (unique-identifiers-for-list types)) - (emit:declarations types output-temps #f port level) - (indent level port) - (format port "~a(~a);\n" - operator-name - (string-join (map symbol->string (append arg-temps output-temps)) - ", ")) - output-temps) - -(define (emit:struct-ref type exp field stage version port level) - (define input-temp (single-temp (emit-glsl exp stage version port level))) - (define output-temp (unique-identifier)) - (indent level port) - (format port "~a ~a = ~a.~a;\n" - (type->glsl type) - output-temp - input-temp - field) - (list output-temp)) - -(define (emit:array-ref type array-exp index-exp stage version port level) - (define array-temp (single-temp (emit-glsl array-exp stage version port level))) - (define index-temp (single-temp (emit-glsl index-exp stage version port level))) - (define output-temp (unique-identifier)) - (indent level port) - (format port "~a ~a = ~a[~a];\n" - (type->glsl type) - output-temp - array-temp - index-temp) - (list output-temp)) - -(define (emit:top-level bindings body stage version port level) - (define (glsl-qualifier qualifier) - (case qualifier - ((in) - (if (string>= version "1.3") 'in 'attribute)) - ((out) - (if (string>= version "1.3") 'out 'varying)) - ((uniform) - 'uniform))) - (for-each (match-lambda - (((? top-level-qualifier? qualifier) type-desc name) - (format port "~a ~a ~a;\n" - (glsl-qualifier qualifier) - (type-descriptor->glsl type-desc) - name)) - (('function name ('t (type) ('lambda params body))) - (emit:function name type params body stage version port level))) - bindings) - (display "void main() {\n" port) - (emit-glsl body stage version port (+ level 1)) - (display "}\n" port)) - -(define (glsl-output-name name) - (let ((variable (lookup-output-variable name))) - (if (seagull-variable? variable) - (seagull-variable-glsl-name variable) - name))) - -(define (emit:outputs names exps stage version port level) - (if (and (eq? stage 'fragment) (null? names)) - (begin - (indent level port) - (format port "discard;\n")) - (for-each (lambda (name exp) - (match (emit-glsl exp stage version port level) - ((temp) - (indent level port) - (format port "~a = ~a;\n" - (glsl-output-name name) - temp)))) - names exps)) - '(#f)) - -(define (glsl-input-name name) - (let ((variable (lookup-input-variable name))) - (if (seagull-variable? variable) - (seagull-variable-glsl-name variable) - name))) - -(define* (emit-glsl exp stage version port #:optional (level 0)) - (match exp - (('t _ (? exact-integer? n)) - (emit:int n stage version port level)) - (('t _ (? float? n)) - (emit:float n stage version port level)) - (('t _ (? boolean? b)) - (emit:boolean b stage version port level)) - (('t _ (? symbol? var)) - (list (glsl-input-name var))) - (('t _ ('if predicate consequent alternate)) - (emit:if predicate consequent alternate stage version port level)) - (('t _ ('values exps ...)) - (emit:values exps stage version port level)) - (('t types ('let ((names exps) ...) body)) - (emit:let types names exps body stage version port level)) - (('t types ('let-values ((names exps) ...) body)) - (emit:let-values types names exps body stage version port level)) - (('t (type) ('primcall op args ...)) - (emit:primcall type op args stage version port level)) - (('t types ('call operator args ...)) - (emit:call types operator args stage version port level)) - (('t (type) ('struct-ref exp field)) - (emit:struct-ref type exp field stage version port level)) - (('t (type) ('array-ref array-exp index-exp)) - (emit:array-ref type array-exp index-exp stage version port level)) - (('t _ ('outputs (names exps) ...)) - (emit:outputs names exps stage version port level)) - (('t _ ('top-level (bindings ...) body)) - (emit:top-level bindings body stage version port level)))) - - -;;; -;;; Compiler front-end -;;; - -;; Combine all of the compiler passes on a user provided program and -;; emit GLSL code if the program is valid. - -(define &seagull-compiler-error - (make-exception-type '&seagull-compiler-error &error '())) - -(define make-seagull-compiler-error - (record-constructor &seagull-compiler-error)) - -(define (seagull-compiler-error msg args origin) - (raise-exception - (make-exception - (make-seagull-compiler-error) - (make-exception-with-origin origin) - (make-exception-with-message - (format #f "seagull compilation error: ~a" msg)) - (make-exception-with-irritants args)))) - -(define-record-type <seagull-global> - (make-seagull-global qualifier type-descriptor name) - seagull-global? - (qualifier seagull-global-qualifier) - (type-descriptor seagull-global-type-descriptor) - (name seagull-global-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 #:key stage body - (inputs '()) (outputs '()) (uniforms '())) - (unless (memq stage '(vertex fragment)) - (seagull-compiler-error "invalid shader stage" (list stage) compile-seagull)) - (parameterize ((unique-identifier-counter 0) - (unique-variable-type-counter 0)) - (let ((source* `(top-level ,(append inputs outputs uniforms) - ,body))) - (define-values (expanded global-map) - (expand* source* stage)) - (let* ((simplified (simplify expanded (empty-env))) - (pruned (prune simplified)) - (hoisted (hoist-functions* pruned)) - (inferred (infer* hoisted stage)) - (resolved (resolve-overloads inferred stage))) - (values resolved global-map (unique-identifier-counter)))))) - -(define (specs->globals specs) - (map (match-lambda - ((qualifier type-desc name) - (make-seagull-global qualifier type-desc name))) - specs)) - -(define (partition-globals exps) - (let loop ((exps exps) - (inputs '()) - (outputs '()) - (uniforms '())) - (match exps - (((and ('in _ _) spec) . rest) - (loop rest (cons spec inputs) outputs uniforms)) - (((and ('out _ _) spec) . rest) - (loop rest inputs (cons spec outputs) uniforms)) - (((and ('uniform _ _) spec) . rest) - (loop rest inputs outputs (cons spec uniforms))) - ((body ...) - (values (reverse inputs) - (reverse outputs) - (reverse uniforms) - `(begin ,@body)))))) - -;; Allow importing Scheme values into Seagull expressions with special -;; '$' syntax, such as numeric constants or user-defined shader types. -(define-syntax seagull-quasiquote - (syntax-rules ($) - ((_ ($ x)) x) - ((_ (x ...)) (list (seagull-quasiquote x) ...)) - ((_ x) (quote x)))) - -;; Using syntax-case allows us to compile shaders to their fully typed -;; intermediate form at compile time, leaving only GLSL emission for -;; runtime. -(define-syntax define-shader-stage - (lambda (x) - (syntax-case x () - ((_ name stage body ...) - (let*-values (((inputs outputs uniforms body) - (partition-globals - (syntax->datum - (eval #'(seagull-quasiquote (body ...)) - (current-module)))))) - (define-values (compiled global-map max-id) - (compile-seagull #:stage (syntax->datum #'stage) - #:inputs inputs - #:outputs outputs - #:uniforms uniforms - #:body body)) - (with-syntax ((inputs (datum->syntax x inputs)) - (outputs (datum->syntax x outputs)) - (uniforms (datum->syntax x uniforms)) - (compiled (datum->syntax x compiled)) - (global-map (datum->syntax x global-map)) - (max-id (datum->syntax x max-id)) - (body (datum->syntax x body))) - #'(define name - (make-seagull-module #:stage 'stage - #:inputs (specs->globals 'inputs) - #:outputs (specs->globals 'outputs) - #:uniforms (specs->globals 'uniforms) - #:source 'body - #:compiled 'compiled - #: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-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))) - (every (lambda (o1) - (any (lambda (o2) - (and (eq? (seagull-global-name o1) - (seagull-global-name o2)) - (equal? (seagull-global-type-descriptor o1) - (seagull-global-type-descriptor o2)))) - fragment-inputs)) - (seagull-module-outputs vertex)))) - -(define (uniforms-compatible? vertex fragment) - (let ((fragment-uniforms (seagull-module-uniforms fragment))) - (every (lambda (u1) - (every (lambda (u2) - (if (eq? (seagull-global-name u1) - (seagull-global-name u2)) - (equal? (seagull-global-type-descriptor u1) - (seagull-global-type-descriptor u2)) - #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) - (define (map-globals specs global-map) - (map (lambda (global) - (let ((name (seagull-global-name global))) - (cons name (assq-ref global-map name)))) - specs)) - (define (alpha-rename name-map) - (map (match-lambda - ((original-name . alpha-name) - (cons alpha-name (unique-identifier)))) - name-map)) - (define (remap specs global-map alpha-map) - (map (lambda (global) - (let ((name (seagull-global-name global))) - (cons (assq-ref alpha-map (assq-ref global-map name)) - name))) - specs)) - (let* ((vertex-global-map (seagull-module-global-map vertex)) - ;; Create a Scheme name -> alpha-converted GLSL name mapping - ;; for vertex outputs. - (vertex-output-map (map-globals (seagull-module-outputs vertex) - vertex-global-map)) - ;; Create a Scheme name -> alpha-converted GLSL name mapping - ;; for vertex uniforms. - (vertex-uniform-map (map-globals (seagull-module-uniforms vertex) - vertex-global-map)) - ;; Give new GLSL names to the vertex outputs and uniforms - ;; that are unique to both the vertex and fragment shaders. - ;; The vertex output names are changed so that the fragment - ;; input names can be changed to match. The vertex uniform - ;; names are changed so that the names do not clash with - ;; fragment globals. - (vertex-output-alpha-map (alpha-rename vertex-output-map)) - (vertex-uniform-alpha-map (alpha-rename vertex-uniform-map)) - (fragment-global-map (seagull-module-global-map fragment)) - ;; Create a Scheme name -> alpha-converted GLSL name mapping - ;; for fragment inputs. - (fragment-input-map (map-globals (seagull-module-inputs fragment) - fragment-global-map)) - ;; Create a Scheme name -> alpha-converted GLSL name mapping - ;; for fragment uniforms. - (fragment-uniform-map (map-globals (seagull-module-uniforms fragment) - fragment-global-map)) - ;; Give new names to the fragment uniforms so that the names - ;; do not clash with vertex globals and also that any - ;; uniforms in the vertex shader have the *same* name in the - ;; fragment shader. - (fragment-uniform-alpha-map - (map (match-lambda - ((original-name . alpha-name) - (cons alpha-name - (or (assq-ref vertex-uniform-alpha-map - (assq-ref vertex-uniform-map original-name)) - (unique-identifier))))) - fragment-uniform-map)) - ;; This one is a little messy but what's happening is that - ;; the GLSL name for each fragment output is mapped to the - ;; respective renamed input. Vertex shader output names must - ;; match fragment shader input names. - (fragment-input-alpha-map - (append (map (lambda (input) - (let ((name (seagull-global-name input))) - (cons (assq-ref fragment-global-map - name) - (assq-ref vertex-output-alpha-map - (assq-ref vertex-global-map - name))))) - (seagull-module-inputs fragment))))) - ;; Rewrite the intermediate compiled forms of both shader stages - ;; to replace global variable names as needed. - (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)) - ;; Generate a list of alpha-converted GLSL name -> Scheme - ;; name mappings. This will be given to the OpenGL shader - ;; constructor to map the human readable uniform names to - ;; the names they've been given by the compiler. - (append (remap (seagull-module-uniforms vertex) - vertex-global-map - vertex-uniform-alpha-map) - (remap (seagull-module-uniforms fragment) - fragment-global-map - fragment-uniform-alpha-map))))) - -(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 (emit-version-preprocessor version port) - (cond - ((string>= version "3.3") - (format port "#version 330\n")) - ((string>= version "1.3") - (format port "#version 130\n")) - ((string>= version "1.2") - (format port "#version 120\n")) - (else - (seagull-compiler-error "incompatible GLSL version" - (list version) - emit-version-preprocessor)))) - -(define (emit-shims version port) - (when (string<= version "3.3") - (format port " -vec4 texture(sampler2D tex, vec2 coord) { - return texture2D(tex, coord); -} -vec4 texture(samplerCube tex, vec3 coord) { - return textureCube(tex, coord); -} -"))) - -(define (emit-stage exp stage version) - (call-with-output-string - (lambda (port) - (emit-version-preprocessor version port) - (emit-shims version port) - (emit-glsl exp 'fragment version port)))) - -(define* (link-seagull-modules vertex fragment version) - (unless (seagull-module-vertex? vertex) - (seagull-compiler-error "not a vertex shader" - (list vertex) - link-seagull-modules)) - (unless (seagull-module-fragment? fragment) - (seagull-compiler-error "not a fragment shader" - (list fragment) - link-seagull-modules)) - (parameterize ((unique-identifier-counter - (max (seagull-module-max-id vertex) - (seagull-module-max-id fragment)))) - (unless (vertex-outputs-match-fragment-inputs? vertex fragment) - (seagull-compiler-error "vertex outputs do not match fragment inputs" - (list vertex fragment) - link-seagull-modules)) - (unless (uniforms-compatible? vertex fragment) - (seagull-compiler-error "vertex uniforms clash with fragment uniforms" - (list vertex fragment) - link-seagull-modules)) - (define-values (vertex* fragment* uniform-map) - (link-vertex-outputs-with-fragment-inputs vertex fragment)) - (define vertex-glsl (emit-stage vertex* 'vertex version)) - (define fragment-glsl (emit-stage fragment* 'fragment version)) - (values vertex-glsl fragment-glsl uniform-map))) - -(define* (compile-shader vertex fragment #:key - (version (graphics-engine-glsl-version))) - (let-values (((glsl:vertex glsl:fragment uniform-map) - (link-seagull-modules vertex fragment version))) - (call-with-input-string glsl:vertex - (lambda (vertex-port) - (call-with-input-string glsl:fragment - (lambda (fragment-port) - (make-shader vertex-port fragment-port - #:uniform-map uniform-map - #:pre-process? #f))))))) - - -;;; -;;; REPL integration -;;; - -(define-meta-command ((seagull-expand chickadee) repl stage exp) - "seagull-expand STAGE EXP -Run the expander on EXP for shader STAGE." - (parameterize ((unique-identifier-counter 0)) - (pretty-print (expand* exp stage)))) - -(define-meta-command ((seagull-simplify chickadee) repl stage exp) - "seagull-simplify STAGE EXP -Run the partial evaluator on EXP for shader STAGE." - (parameterize ((unique-identifier-counter 0)) - (pretty-print (simplify* (expand* exp stage))))) - -(define-meta-command ((seagull-infer chickadee) repl stage exp) - "seagull-infer STAGE EXP -Run type inference on EXP for shader STAGE." - (parameterize ((unique-identifier-counter 0)) - (pretty-print - (infer* (hoist-functions* - (prune - (simplify* - (expand* exp stage)))) - stage)))) - -(define-meta-command ((seagull-inspect chickadee) repl module) - "seagull-inspect MODULE -Show the intermediate compiled form of MODULE." - (pretty-print (seagull-module-compiled (repl-eval repl module)))) - -(define-meta-command ((seagull-compile chickadee) repl vertex fragment - #:optional (version (graphics-engine-glsl-version))) - "seagull-compile VERTEX-MODULE FRAGMENT-MODULE -Show the compiled GLSL form of VERTEX-MODULE and FRAGMENT-MODULE." - (define-values (vertex-glsl fragment-glsl uniform-map) - (link-seagull-modules (repl-eval repl vertex) - (repl-eval repl fragment) - version)) - (format #t "Vertex GLSL:\n\n~a\n" vertex-glsl) - (format #t "Fragment GLSL:\n\n~a" fragment-glsl)) + #:export (compile-seagull + compile-vertex + compile-fragment) + #:re-export ($gl)) + +(define (pretty-pk x) + (pretty-print x) + x) + +(define (pretty-pk-cps x) + (pretty-print (graph->sexp x)) + x) + +(define (compile-seagull exp stage) + (define-values (graph types subs) + (infer + (pretty-pk-cps + (linearize + (pretty-pk + (expand exp stage)))))) + ;;(unbox-substitutions subs) + (emit-glsl graph)) + +(define (compile-vertex exp) + (compile-seagull exp stage:vertex)) + +(define (compile-fragment exp) + (compile-seagull exp stage:fragment)) + +;; ILs: +;; - Base +;; - Untyped CPS +;; - Typed CPS + +;; Passes: +;; - Expansion +;; - Partial evaluation +;; - CPS +;; - Type inference +;; - GLSL emission + +;; Importable things: +;; - floats +;; - ints +;; - shader types +;; - shader functions + + + + +;; vec3 toneMap(vec3 color) { +;; return color / (color + vec3(1.0)); +;; } +'(define tone-map + (seagull + (lambda (color) + (/ color (+ color (vec3 1.0)))))) +'(define-seagull (tone-map color) + (/ color (+ color (vec3 1.0)))) + +'(define-seagull (tone-map/red color) + #:import (tone-map) + (vec3 (-> (tone-map color) x))) + +'(define-seagull pi 3.14159) + +'(define-seagull sprite-vertex + (vertex-shader + #:in ((position vec2) + (tex vec2) + (tint vec2)) + #:uniform ((mvp mat4)) + #:out ((vertex:position vec4) + (frag-text vec2) + (frag-tint vec4)) + #:import (tone-map) + (values + (vertex:position (* mvp (vec4 position 0.0 1.0))) + (frag-tex tex) + (frag-tint (tone-map tint))))) + +;; (define-record-type <seagull-syntax> +;; (make-seagull-syntax source exp) +;; seagull-syntax? +;; (source seagull-syntax-source) +;; (exp seagull-syntax-expression)) + +;; (define (assert-seagull-syntax obj) +;; (unless (seagull-syntax? obj) +;; (throw 'not-seagull-syntax obj))) + +;; (define-record-type <seagull-constant> +;; (make-seagull-constant value) +;; seagull-constant? +;; (value seagull-constant-value)) + +;; (define (seagull-constant x) +;; (unless (constant? x) +;; (throw 'not-a-constant x)) +;; (make-seagull-constant x)) + +;; (define-record-type <seagull-reference> +;; (make-seagull-reference name) +;; seagull-reference? +;; (name seagull-reference-name)) + +;; (define (seagull-reference name) +;; (unless (symbol? name) +;; (throw 'invalid-reference name)) +;; (make-seagull-reference name)) + +;; (define-record-type <seagull-primcall> +;; (make-seagull-primcall name args) +;; seagull-primcall? +;; (name seagull-primcall-name) +;; (args seagull-primcall-args)) + +;; (define (seagull-primcall name . args) +;; (for-each assert-seagull-syntax args) +;; (make-seagull-primcall name args)) + +;; (define-record-type <seagull-if> +;; (make-seagull-if predicate consequent alternate) +;; seagull-if? +;; (predicate seagull-if-predicate) +;; (consequent seagull-if-consequent) +;; (alternate seagull-if-alternate)) + +;; (define (seagull-if predicate consequent alternate) +;; (assert-seagull-syntax predicate) +;; (assert-seagull-syntax consequent) +;; (assert-seagull-syntax alternate) +;; (make-seagull-if predicate consequent alternate)) + +;; ;; ((lambda (x) +;; ;; (syntax-case x () +;; ;; ((_ exp) +;; ;; (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp)))) +;; ;; #'(make-seagull-syntax src exp))))) +;; ;; (call-with-input-string "(foo 1)" read-syntax)) + +;; (define-syntax seagull-syntax +;; (lambda (x) +;; (syntax-case x () +;; ((_ exp) +;; (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp)))) +;; #'(make-seagull-syntax src exp)))))) + +;; (define (seagull-identity x) +;; (assert-seagull-syntax x) +;; x) + +;; (define-syntax-rule (sgl:const x) +;; (seagull-syntax (seagull-constant x))) + +;; (define-syntax-rule (sgl:ref name) +;; (seagull-syntax (seagull-reference 'name))) + +;; (define-syntax-rule (sgl:if predicate consequent alternate) +;; (seagull-syntax (seagull-if predicate consequent alternate))) + +;; (define-syntax sgl:cond +;; (syntax-rules (else) +;; ((_ (else exp)) +;; (seagull-identity exp)) +;; ((_ (pred body) rest ...) +;; (sgl:if pred body (sgl:cond rest ...))))) + +;; (define-syntax sgl:+ +;; (syntax-rules () +;; ((_) +;; (sgl:const 0)) +;; ((_ x) +;; (seagull-identity x)) +;; ((_ x rest ...) +;; (seagull-syntax (seagull-primcall '+ x (sgl:+ rest ...)))))) + +;; (sgl:+) +;; (sgl:+ (sgl:const 1)) +;; (sgl:+ (sgl:const 1) (sgl:ref x)) +;; (sgl:if (sgl:const #t) +;; (sgl:+ (sgl:const 1) (sgl:const 2) (sgl:const 3)) +;; (sgl:+ (sgl:const 4) (sgl:const 5) (sgl:const 6))) +;; (sgl:cond +;; ((sgl:const #t) +;; (sgl:+ (sgl:const 1) (sgl:const 2) (sgl:const 3))) +;; (else +;; (sgl:+ (sgl:const 4) (sgl:const 5) (sgl:const 6)))) + +;; (define (my+ a b) +;; `(sum ,(+ a b))) + +;; (define-syntax weird+ +;; (lambda (x) +;; (syntax-case x () +;; ((_ exp) +;; (with-syntax ((+ (datum->syntax #'exp '+))) +;; #'(let ((+ sgl:+)) +;; exp)))))) + +;; (define (s+ x y) `(primcall + ,x ,y)) +;; (define (s* x y) `(primcall * ,x ,y)) +;; (define-syntax seagull +;; (lambda (x) +;; (syntax-case x () +;; ((_ exp) +;; (with-syntax ((+ (datum->syntax x '+)) +;; (* (datum->syntax x '*))) +;; #'(let ((+ s+) (* s*)) exp)))))) + +;; (seagull (+ (* 2 2) (* 3 3))) + +;; (define-syntax $gl-expand +;; (lambda (x) +;; (syntax-case x () +;; ((_ (f y z)) +;; (with-syntax ((+ (datum->syntax x 'sgl:+))) +;; #'(+ y z)))))) + +;; ($gl-expand (+ 1 2)) + +;; ;; Annotate seagull expressions with source information, producing +;; ;; seagull-specific syntax objects that can't be confused with scheme +;; ;; syntax objects. +;; (define-syntax $gl +;; (lambda (x) +;; (syntax-case x () +;; ((_ exp) +;; (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp)))) +;; #'(seagull-syntax src ($gl-recur exp))))))) + +;; ;; Helper macro to annotate nested expressions. +;; (define-syntax $gl-recur +;; (syntax-rules () +;; ((_ (item ...)) +;; (list ($gl item) ...)) +;; ((_ atom) +;; atom))) diff --git a/chickadee/graphics/seagull/base.scm b/chickadee/graphics/seagull/base.scm new file mode 100644 index 0000000..27f5886 --- /dev/null +++ b/chickadee/graphics/seagull/base.scm @@ -0,0 +1,313 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; The base intermediate language for Seagull, before it is converted +;; to continuation-passing style. No static type checking at this +;; level. Analogous to Guile's Tree-IL. +(define-module (chickadee graphics seagull base) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (<constant> + make-constant + constant? + constant-source + constant-value + + <lexical-reference> + make-lexical-reference + lexical-reference? + lexical-reference-source + lexical-reference-source-name + lexical-reference-name + + <struct-reference> + make-struct-reference + struct-reference? + struct-reference-source + struct-reference-value + struct-reference-field + + <array-reference> + make-array-reference + array-reference? + array-reference-source + array-reference-value + array-reference-index + + <assignment> + make-assignment + assignment? + assignment-source + assignment-source-name + assignment-name + assignment-value + + <values> + make-values + values? + values-source + values-expressions + + <sequence> + make-sequence + sequence? + sequence-source + sequence-expressions + + <let> + make-let + let? + let-source + let-source-names + let-names + let-expressions + let-body + + <let-values> + make-let-values + let-values? + let-values-source + let-values-source-names + let-values-names + let-values-expressions + let-values-body + + <conditional> + make-conditional + conditional? + conditional-source + conditional-predicate + conditional-consequent + conditional-alternate + + <function> + make-function + function? + function-source + function-source-names + function-names + function-body + + <primitive-call> + make-primitive-call + primitive-call? + primitive-call-source + primitive-call-name + primitive-call-arguments + + <call> + make-call + call? + call-source + call-function + call-arguments + + <discard> + make-discard + discard? + discard-source + + base->sexp + sexp->base)) + +(define-record-type <constant> + (make-constant source value) + constant? + (source constant-source) + (value constant-value)) + +(define-record-type <lexical-reference> + (make-lexical-reference source source-name name) + lexical-reference? + (source lexical-reference-source) + (source-name lexical-reference-source-name) + (name lexical-reference-name)) + +(define-record-type <struct-reference> + (make-struct-reference source value field) + struct-reference? + (source struct-reference-source) + (value struct-reference-value) + (field struct-reference-field)) + +(define-record-type <array-reference> + (make-array-reference source value index) + array-reference? + (source array-reference-source) + (value array-reference-value) + (index array-reference-index)) + +(define-record-type <assignment> + (make-assignment source source-name name value) + assignment? + (source assignment-source) + (source-name assignment-source-name) + (name assignment-name) + (value assignment-value)) + +(define-record-type <values> + (make-values source expressions) + values? + (source values-source) + (expressions values-expressions)) + +(define-record-type <sequence> + (make-sequence source expressions) + sequence? + (source sequence-source) + (expressions sequence-expressions)) + +(define-record-type <let> + (make-let source source-names names expressions body) + let? + (source let-source) + (source-names let-source-names) + (names let-names) + (expressions let-expressions) + (body let-body)) + +(define-record-type <let-values> + (make-let-values source source-names names expressions body) + let-values? + (source let-values-source) + (source-names let-values-source-names) + (names let-values-names) + (expressions let-values-expressions) + (body let-values-body)) + +(define-record-type <conditional> + (make-conditional source predicate consequent alternate) + conditional? + (source conditional-source) + (predicate conditional-predicate) + (consequent conditional-consequent) + (alternate conditional-alternate)) + +(define-record-type <function> + (make-function source source-names names body) + function? + (source function-source) + (source-names function-source-names) + (names function-names) + (body function-body)) + +(define-record-type <primitive-call> + (make-primitive-call source name arguments) + primitive-call? + (source primitive-call-source) + (name primitive-call-name) + (arguments primitive-call-arguments)) + +(define-record-type <call> + (make-call source function arguments) + call? + (source call-source) + (function call-function) + (arguments call-arguments)) + +(define-record-type <discard> + (make-discard source) + discard? + (source discard-source)) + +(define (base->sexp exp) + (match exp + (($ <constant> _ value) + `(constant ,value)) + (($ <lexical-reference> _ name _) + `(lexical-reference ,name)) + (($ <struct-reference> _ value field) + `(struct-reference ,(base->sexp value) ,field)) + (($ <array-reference> _ value index) + `(array-reference ,(base->sexp value) ,index)) + (($ <assignment> _ name _ value) + `(assignment ,name ,(base->sexp value))) + (($ <values> _ exps) + `(values ,@(map base->sexp exps))) + (($ <sequence> _ exps) + `(sequence ,@(map base->sexp exps))) + (($ <let> _ names _ exps body) + `(let ,(zip names (map base->sexp exps)) ,(base->sexp body))) + (($ <let-values> _ names _ exps body) + `(let-values ,(zip names (map base->sexp exps)) ,(base->sexp body))) + (($ <conditional> _ predicate consequent alternate) + `(conditional ,(base->sexp predicate) + ,(base->sexp consequent) + ,(base->sexp alternate))) + (($ <function> _ names _ body) + `(function ,names ,(base->sexp body))) + (($ <primitive-call> _ op args) + `(primitive-call ,op ,@(map base->sexp args))) + (($ <call> _ function args) + `(call ,(base->sexp function) ,@(map base->sexp args))) + (($ <discard> _) + '(discard)))) + +;; Useful for tests. +(define (sexp->base exp) + (match exp + (('constant value) + (make-constant #f value)) + (('lexical-reference (? symbol? name)) + (make-lexical-reference #f name name)) + (('struct-reference value (? symbol? field)) + (make-struct-reference #f (sexp->base value) field)) + (('array-reference value index) + (make-array-reference #f (sexp->base value) (sexp->base index))) + (('assignment (? symbol? name) value) + (make-assignment #f name name (sexp->base value))) + (('values exps ...) + (make-values #f (map sexp->base exps))) + (('sequence exps ...) + (make-sequence #f (map sexp->base exps))) + (('let ((names exps) ...) body) + (make-let #f names names (map sexp->base exps) (sexp->base body))) + (('let-values (((names ...) exps) ...) body) + (make-let-values #f names names (map sexp->base exps) (sexp->base body))) + (('conditional predicate consequent alternate) + (make-conditional #f + (sexp->base predicate) + (sexp->base consequent) + (sexp->base alternate))) + (('function (names ...) body) + (make-function #f names names (sexp->base body))) + (('primitive-call (? symbol? op) args ...) + (make-primitive-call #f op (map sexp->base args))) + (('call function args ...) + (make-call #f (sexp->base function) (map sexp->base args))) + (('discard) + (make-discard #f)))) + +(define (print-base exp port) + (format port "#<base ~a>" (base->sexp exp))) + +(set-record-type-printer! <constant> print-base) +(set-record-type-printer! <lexical-reference> print-base) +(set-record-type-printer! <struct-reference> print-base) +(set-record-type-printer! <array-reference> print-base) +(set-record-type-printer! <assignment> print-base) +(set-record-type-printer! <values> print-base) +(set-record-type-printer! <sequence> print-base) +(set-record-type-printer! <let> print-base) +(set-record-type-printer! <let-values> print-base) +(set-record-type-printer! <conditional> print-base) +(set-record-type-printer! <function> print-base) +(set-record-type-printer! <primitive-call> print-base) +(set-record-type-printer! <call> print-base) +(set-record-type-printer! <discard> print-base) diff --git a/chickadee/graphics/seagull/cps.scm b/chickadee/graphics/seagull/cps.scm new file mode 100644 index 0000000..3c2f1fe --- /dev/null +++ b/chickadee/graphics/seagull/cps.scm @@ -0,0 +1,306 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; A simple form of a continuation-passing style intermediate +;; language. This intermediate representation provides a control flow +;; graph. Inspired by Guile's CPS soup but simplified because our +;; compilation target is a lot simpler than what a general purpose +;; language needs to handle and also I'm a compiler baby and not a +;; genius like Andy Wingo. Unlike Guile's CPS, Seagull's CPS is +;; statically typed. The initial CPS conversion pass leaves the type +;; annotations blank but the type inference pass must ultimately be +;; able to assign types to all variables and functions or else the +;; program is not valid. +(define-module (chickadee graphics seagull cps) + #:use-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 match) + #:use-module (language cps intmap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (<arguments> + make-arguments + arguments? + arguments-names + arguments-term + arguments-types + + <function-entry> + make-function-entry + function-entry? + function-entry-source + function-entry-params + function-entry-results + function-entry-start + function-entry-return + function-entry-type + + <continue> + make-continue + continue? + continue-source + continue-label + continue-expression + + <return> + make-return + return? + return-outputs + + <branch> + make-branch + branch? + branch-source + branch-name + branch-consequent + branch-alternate + + <discard> + make-discard + discard? + discard-source + + <cps-constant> + make-cps-constant + cps-constant? + cps-constant-value + cps-constant-type + + <cps-primitive-call> + make-cps-primitive-call + cps-primitive-call? + cps-primitive-call-operator + cps-primitive-call-arguments + cps-primitive-call-types + + <cps-call> + make-cps-call + cps-call? + cps-call-function + cps-call-arguments + cps-call-type + + <cps-values> + make-cps-values + cps-values? + cps-values-arguments + + <cps-assignment> + make-cps-assignment + cps-assignment? + cps-assignment-variable + cps-assignment-value + + <cps-function> + make-cps-function + cps-function? + cps-function-body + + continuation? + term? + expression? + cps->sexp + sexp->cps + graph->sexp + sexp->graph)) + +;; Continuations +(define-record-type <arguments> + (make-arguments names term types) + arguments? + (names arguments-names) + (term arguments-term) + (types arguments-types)) + +(define-record-type <function-entry> + (make-function-entry source params results start return type) + function-entry? + (source function-entry-source) + (params function-entry-params) + (results function-entry-results) + (start function-entry-start) + (return function-entry-return) + (type function-entry-type)) + +(define (continuation? obj) + (or (arguments? obj) + (function-entry? obj))) + +;; Terms +(define-record-type <continue> + (make-continue source label expression) + continue? + (source continue-source) + (label continue-label) + (expression continue-expression)) + +(define-record-type <return> + (make-return outputs) + return? + (outputs return-outputs)) + +(define-record-type <branch> + (make-branch source name consequent alternate) + branch? + (source branch-source) + (name branch-name) + (consequent branch-consequent) + (alternate branch-alternate)) + +;; Discard is available only in fragment shaders and is used to +;; terminate early and throw away the fragment, which means it has no +;; continuation. +(define-record-type <discard> + (make-discard source) + discard? + (source discard-source)) + +(define (term? obj) + (or (continue? obj) + (branch? obj) + (discard? obj))) + +;; Expressions (prefixed with 'cps' to distinguish them from the +;; tree-based IL when both modules are imported) +(define-record-type <cps-constant> + (make-cps-constant value type) + cps-constant? + (value cps-constant-value) + ;; TODO: Unnecessary. Delete it. + (type cps-constant-type)) + +(define-record-type <cps-primitive-call> + (make-cps-primitive-call operator arguments types) + cps-primitive-call? + (operator cps-primitive-call-operator) + (arguments cps-primitive-call-arguments) + ;; TODO: Unused. Delete it. + (types cps-primitive-call-types)) + +(define-record-type <cps-call> + (make-cps-call function arguments types) + cps-call? + (function cps-call-function) + (arguments cps-call-arguments) + ;; TODO: Unused. Delete it. + (types cps-call-types)) + +(define-record-type <cps-values> + (make-cps-values arguments) + cps-values? + (arguments cps-values-arguments)) + +(define-record-type <cps-assignment> + (make-cps-assignment variable value) + cps-assignment? + (variable cps-assignment-variable) + (value cps-assignment-value)) + +(define-record-type <cps-function> + (make-cps-function body) + cps-function? + (body cps-function-body)) + +(define (expression? obj) + (or (cps-constant? obj) + (cps-primitive-call? obj) + (cps-call? obj) + (cps-values? obj))) + +(define (cps->sexp exp) + (match exp + (($ <arguments> names term types) + `(arguments ,names ,(cps->sexp term))) + (($ <function-entry> _ params results start return _) + `(function-entry ,params ,results ,start ,return)) + (($ <return> outputs) + `(return ,@outputs)) + (($ <continue> _ label exp) + `(continue ,label ,(cps->sexp exp))) + (($ <branch> _ name consequent alternate) + `(branch ,name ,consequent ,alternate)) + (($ <discard> _) + '(discard)) + (($ <cps-constant> val _) + `(constant ,val)) + (($ <cps-primitive-call> op args _) + `(primitive-call ,op ,args)) + (($ <cps-call> f args _) + `(call ,f ,args)) + (($ <cps-values> args) + `(values ,@args)) + (($ <cps-assignment> var val) + `(assignment ,var ,val)) + (($ <cps-function> body) + `(function ,body)))) + +(define (graph->sexp graph) + (intmap-fold-right (lambda (k cont memo) + (alist-cons k (cps->sexp cont) memo)) + graph '())) + +(define (sexp->cps exp) + (match exp + (('arguments ((? exact-integer? names) ...) term) + (make-arguments names (sexp->cps term) #f)) + (('function-entry (? exact-integer? name) + ((? exact-integer? params) ...) + ((? exact-integer? results) ...) + (? exact-integer? start) + (? exact-integer? return)) + (make-function-entry #f params results start return #f)) + (('continue (and (or (? exact-integer?) #f) label) exp) + (make-continue #f label (sexp->cps exp))) + (('return outputs ...) + (make-return outputs)) + (('branch (? exact-integer? name) + (? exact-integer? consequent) + (? exact-integer? alternate)) + (make-branch #f name consequent alternate)) + (('discard) + (make-discard #f)) + (('constant val) + (make-cps-constant val (type-for-constant val))) + (('primitive-call (? symbol? op) ((? exact-integer? args) ...)) + (make-cps-primitive-call op args (list (fresh-type-variable)))) + (('call (? exact-integer? f) ((? exact-integer? args) ...)) + (make-cps-call f args (list (fresh-type-variable)))) + (('values (? exact-integer? args) ...) + (make-cps-values args)) + (('assignment (? exact-integer? var) (? exact-integer? val)) + (make-cps-assignment var val)))) + +(define (sexp->graph exp) + (fold (lambda (pair graph) + (match pair + (((? exact-integer? k) . exp*) + (intmap-add graph k (sexp->cps exp*))))) + empty-intmap exp)) + +(define (print-cps cps port) + (format port "<cps ~a>" (cps->sexp cps))) + +(set-record-type-printer! <arguments> print-cps) +(set-record-type-printer! <function-entry> print-cps) +(set-record-type-printer! <return> print-cps) +(set-record-type-printer! <continue> print-cps) +(set-record-type-printer! <branch> print-cps) +(set-record-type-printer! <discard> print-cps) +(set-record-type-printer! <cps-constant> print-cps) +(set-record-type-printer! <cps-primitive-call> print-cps) +(set-record-type-printer! <cps-call> print-cps) +(set-record-type-printer! <cps-values> print-cps) +(set-record-type-printer! <cps-function> print-cps) diff --git a/chickadee/graphics/seagull/glsl.scm b/chickadee/graphics/seagull/glsl.scm new file mode 100644 index 0000000..50f75d6 --- /dev/null +++ b/chickadee/graphics/seagull/glsl.scm @@ -0,0 +1,151 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; CPS to GLSL emitter. +(define-module (chickadee graphics seagull glsl) + #:use-module (chickadee graphics seagull cps) + #:use-module (chickadee graphics seagull primitives) + #:use-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 match) + #:use-module (language cps intmap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (emit-glsl)) + +(define (indent level port) + (unless (= level 0) + (display " " port) + (indent (- level 1) port))) + +(define (variable-name id) + (format #f "v~a" id)) + +(define (emit-glsl* graph k exp level port) + (define (emit-exp exp var type) + (match (pk 'emit-exp exp) + (#f #f) + (($ <cps-constant> val _) + (indent level port) + (format port "~a ~a = ~a;\n" + (type-glsl-name type) + (variable-name var) + (match val + (#t "true") + (#f "false") + (_ val)))) + (($ <cps-values> (arg)) + (indent level port) + (format port "~a ~a = ~a;\n" + (type-glsl-name type) + (variable-name var) + (variable-name arg))) + (($ <cps-assignment> from to) + (indent level port) + (format port "~a = ~a;\n" (variable-name from) (variable-name to))) + (($ <cps-primitive-call> op args _) + (let ((op* (lookup-primitive-operator op))) + (indent level port) + (format port "~a ~a = " + (type-glsl-name type) + (variable-name var)) + (if (primitive-operator-infix? op*) + (match args + ;; Infix binary operator + ((a b) + (format port "~a ~a ~a;\n" + (variable-name a) + (primitive-operator-glsl-name op*) + (variable-name b)))) + ;; Regular function call + (begin + (format port "~a(" (primitive-operator-glsl-name op*)) + (let loop ((args args)) + (match args + (() #t) + ((arg) + (display (variable-name arg) port)) + ((arg . rest) + (format port "~a, " (variable-name arg)) + (loop rest)))) + (format port ");\n"))))) + (($ <cps-function> body) + (match (intmap-ref graph body) + (($ <function-entry> _ params results start return type) + (indent level port) + (format port "function ~a(~a) {\n" + (variable-name var) + (string-join (append (map (lambda (param type) + (param-string 'in param type)) + params (function-type-parameters type)) + (map (lambda (result type) + (param-string 'out result type)) + results (function-type-returns type))) + ", ")) + (pk 'start-function-body) + (emit-glsl* graph start #f (+ level 1) port) + (pk 'done-function-body) + (indent level port) + (format port "}\n")))))) + (define (param-string qualifier var type) + (format #f "~a ~a ~a" + qualifier + (type-glsl-name type) + (variable-name var))) + (match (pk 'emit-cont (intmap-ref graph k)) + (($ <arguments> () ($ <return> ()) ()) + (indent level port) + (format port "return;\n")) + (($ <arguments> (var) ($ <return> (result)) (type)) + (emit-exp exp var type) + (indent level port) + (format port "return;\n")) + (($ <arguments> (var) ($ <return> ()) (type)) + (pk 'blah exp type) + (emit-exp exp var type) + (indent level port) + (indent level port) + (format port "return;\n")) + (($ <arguments> () ($ <continue> _ k* exp*) _) + (emit-exp exp #f #f) + (emit-glsl* graph k* exp* level port)) + (($ <arguments> (var) ($ <continue> _ k* exp*) (type)) + (emit-exp exp var type) + (emit-glsl* graph k* exp* level port)) + (($ <arguments> (var) ($ <branch> _ test k-conseq k-alt) (type)) + (emit-exp exp var type) + (indent level port) + (format port "if(~a) {\n" (variable-name test)) + (emit-glsl* graph k-conseq #f (+ level 1) port) + (format port "} else {\n") + (emit-glsl* graph k-alt #f (+ level 1) port) + (format port "}\n")))) + +(define (emit-glsl graph) + (call-with-output-string + (lambda (port) + (emit-glsl* graph 0 #f 0 port)))) + +;; (define test-cps +;; (let ((int (lookup-type 'int))) +;; (alist->intmap +;; `((0 . ,(make-arguments '() (make-continue #f 1 (make-cps-constant 1)))) +;; (1 . ,(make-arguments '(0) (make-continue #f 3 (make-cps-constant 2)))) +;; (2 . ,(make-arguments '(1) (make-continue #f 5 (make-cps-primitive-call '+ '(0 1) int)))) +;; (3 . ,(make-arguments '(3) (make-continue #f 4 (make-cps-constant 3)))) +;; (4 . ,(make-arguments '(4) (make-continue #f 2 (make-cps-primitive-call '* '(3 4) int)))) +;; (5 . ,(make-arguments '(5) (make-continue #f #f (make-cps-values '(5))))))))) + +;; (emit-glsl test-cps) diff --git a/chickadee/graphics/seagull/pass-expand.scm b/chickadee/graphics/seagull/pass-expand.scm new file mode 100644 index 0000000..cbfd325 --- /dev/null +++ b/chickadee/graphics/seagull/pass-expand.scm @@ -0,0 +1,310 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; The expansion pass transforms a tree of Seagull syntax objects into +;; a tree of primitives in the format of the base intermediate +;; language. The expander also takes care of "alpha conversion", +;; which is a fancy math way of saying that all names are given new, +;; unique names so that the compiler doesn't have to worry about name +;; collisions, like if '+' refers to the primitive addition function +;; or a lexical variable that shadows it. +(define-module (chickadee graphics seagull pass-expand) + #:use-module (chickadee graphics seagull base) + #:use-module (chickadee graphics seagull primitives) + #:use-module (chickadee graphics seagull syntax) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (expand)) + +;; Unique name generation. +(define name-counter (make-parameter 0)) + +(define (reset-name-counter!) + (name-counter 0)) + +(define (next-name-id) + (let ((id (name-counter))) + (name-counter (+ id 1)) + id)) + +(define (fresh-name) + (string->symbol (format #f "t~a" (next-name-id)))) + +(define (fresh-names names) + (map (lambda (_name) (fresh-name)) names)) + +(define (alpha-convert names) + (define names* (map (lambda (_name) (fresh-name)) names)) + (fold extend (fresh-environment) names names*)) + +(define (expand:list exps stage env) + (map (lambda (x) (expand* x stage env)) exps)) + +(define (expand:body body src stage env) + (match body + ;; Empty body, invalid. + (() + (seagull-syntax-error "body requires at least one expression" + (build-syntax src '()) + expand:discard)) + ;; Body with a single expression, just expand that expression. + ((exp) + (expand* exp stage env)) + ;; Body with multiple expressions, expand to a sequence. + ((exps ...) + (make-sequence src (expand:list exps stage env))))) + +;; Lookup alpha-converted name for the given source name. +(define (expand:reference name src stage env) + (let ((name* (lookup name env))) + (unless name* + (seagull-syntax-error "unbound variable" + (make-seagull-syntax src name) + expand:reference)) + (make-lexical-reference src name name*))) + +(define (expand:if predicate consequent alternate src stage env) + (make-conditional src + (expand* predicate stage env) + (expand* consequent stage env) + (expand* alternate stage env))) + +(define (expand:function params body src stage env) + (define params* (fresh-names params)) + (define env* (fold extend env params params*)) + (make-function src params params* + (expand:body body src stage env*))) + +(define (expand:primcall operator arguments src stage env) + (let* ((op (lookup-primitive-operator operator)) + (op:expand (primitive-operator-expand op))) + (op:expand arguments src (lambda (stx) (expand* stx stage env))))) + +(define (expand:call function arguments src stage env) + (make-call src (expand* function stage env) + (expand:list arguments stage env))) + +(define (expand:let names values body src stage env) + (match names + (() + (expand:body body src stage env)) + (_ + (let* ((values* (expand:list values stage env)) + (names* (fresh-names names)) + (env* (fold extend env names names*))) + (make-let src names names* values* (expand:body body src stage env*)))))) + +(define (expand:let-values names values body src stage env) + (match names + (() + (expand:body body src stage env)) + (_ + (let* ((values* (expand:list values stage env)) + (names* (map fresh-names names)) + (env* (fold extend env (concatenate names) (concatenate names*)))) + (make-let-values src names names* values* (expand:body body src stage env*)))))) + +(define (expand:values exps src stage env) + (make-values src (expand:list exps stage env))) + +(define (expand:struct-ref value fields src stage env) + (define value* (expand* value stage env)) + (match fields + ((field . rest) + (let loop ((fields rest) + (prev (make-struct-reference src value* field))) + (match fields + (() prev) + ((field . rest) + (loop rest (make-struct-reference src prev field)))))))) + +(define (expand:array-ref value indices src stage env) + (define value* (expand* value stage env)) + (match indices + ((i . rest) + (let ((i* (expand* i stage env))) + (let loop ((indices rest) + (prev (make-array-reference src value* i*))) + (match indices + (() prev) + ((j . rest) + (let ((j* (expand* j stage env))) + (loop rest (make-array-reference src prev j*)))))))))) + +(define (expand:assignment name value src stage env) + (make-assignment src name (lookup name env) (expand* value stage env))) + +(define (expand:discard src stage) + (unless (fragment-stage? stage) + (seagull-syntax-error "'discard' is only permitted in fragment shaders" + (build-syntax src '(discard)) + expand:discard))) + +;; Macros: +(define (expand:let* bindings body src stage env) + (match bindings + (() + (expand* body stage env)) + ((binding . rest) + (expand* (build-syntax (seagull-syntax-source binding) + `(let (,binding) + (let* ,rest ,body))) + stage env)))) + +(define (expand:or exps src stage env) + (match exps + (() + (make-constant src #f)) + ((exp) + (expand* exp stage env)) + ((exp . rest) + (expand* (build-syntax src `(let ((x ,exp)) (if x x (or ,@rest)))) + stage env)))) + +(define (expand:and exps src stage env) + (match exps + (() + (make-constant src #t)) + ((exp) + (expand* exp stage env)) + ((exp . rest) + (expand* (build-syntax src `(if ,exp (and ,@rest) #f)) + stage env)))) + +(define (expand:cond clauses src stage env) + (define (cond->if clauses*) + (match clauses* + ;; Our version of 'cond' requires a final 'else' clause because + ;; the static type checker enforces that both branches of an + ;; 'if' must be the same type. If 'else' were optional then we + ;; wouldn't know what type the final alternate branch should be. + ((($ <syntax> _ (($ <syntax> _ 'else) exp))) + exp) + ((($ <syntax> _ (predicate consequent)) . rest) + (build-syntax src `(if ,predicate ,consequent ,(cond->if rest)))) + (() + (seagull-syntax-error "'cond' form must end with 'else' clause" + (build-syntax src `(cond ,@clauses)) + expand:cond)) + (_ + (seagull-syntax-error "invalid 'cond' form" + (build-syntax src `(cond ,@clauses)) + expand:cond)))) + (expand* (cond->if clauses) stage env)) + +(define (expand:case key clauses src stage env) + (define (case->if clauses*) + (match clauses* + ;; Like our version of 'cond', our version of 'case' requires a + ;; final 'else' clause. + ((($ <syntax> _ (($ <syntax> _ 'else) exp))) + exp) + ((($ <syntax> _ (($ <syntax> _ (possibilities ..1)) consequent)) . rest) + (build-syntax src + `(if (or ,@(map (lambda (n) `(= key ,n)) possibilities)) + ,consequent + ,(case->if rest)))) + (() + (seagull-syntax-error "'case' form must end with 'else' clause" + (build-syntax src `(case ,key ,@clauses)) + expand:case)) + (_ + (seagull-syntax-error "invalid 'case' form" + (build-syntax src `(case ,key ,@clauses)) + expand:case)))) + (expand* (build-syntax src + `(let ((key ,key)) + ,(case->if clauses))) + stage env)) + +;; Constant types are fundamental data types that need no compilation. +(define (primitive-constant? x) + (or (exact-integer? x) + (float? x) + (boolean? x))) + +(define (primitive-operator-for-stage? name stage) + (let ((op (lookup-primitive-operator name))) + (and op (memq stage (primitive-operator-stages op))))) + +(define (expand* syntax stage env) + (define (lexically-bound? x) + (and (symbol? x) (bound? x env))) + (define (primop? x) + (and (symbol? x) (primitive-operator-for-stage? x stage))) + (define src (seagull-syntax-source syntax)) + (match (seagull-syntax-expression syntax) + ;; Constants and variable references + ((? primitive-constant? c) + (make-constant src c)) + ((? symbol? name) + (expand:reference name src stage env)) + ;; Function call with a variable reference in operator position + ;; that *might* shadow a built-in, so we need to check for it + ;; early. + (((and ($ <syntax> name-src (? lexically-bound?)) function) arguments ...) + (expand:call function arguments src stage env)) + ;; Primitive syntax + ((($ <syntax> _ 'if) predicate consequent alternate) + (expand:if predicate consequent alternate src stage env)) + ((($ <syntax> _ 'lambda) + ($ <syntax> _ (($ <syntax> _ (? symbol? params)) ...)) + body ...) + (expand:function params body src stage env)) + ((($ <syntax> _ 'let) + ($ <syntax> _ (($ <syntax> _ (($ <syntax> _ (? symbol? names)) + values)) + ...)) + body ...) + (expand:let names values body src stage env)) + ((($ <syntax> _ 'let-values) + ($ <syntax> _ (($ <syntax> _ (($ <syntax> _ (($ <syntax> _ (? symbol? names)) ...)) + values)) + ...)) + body ...) + (expand:let-values names values body src stage env)) + ((($ <syntax> _ 'values) exps ...) + (expand:values exps src stage env)) + ((($ <syntax> _ '->) value ($ <syntax> _ (? symbol? fields)) ..1) + (expand:struct-ref value fields src stage env)) + ((($ <syntax> _ '@) value indices ..1) + (expand:array-ref value indices src stage env)) + ((($ <syntax> _ 'set!) ($ <syntax> _ (? symbol? name)) value) + (expand:assignment name value src stage env)) + ((($ <syntax> _ 'discard)) + (expand:discard src stage)) + ;; Built-in macros + ((($ <syntax> _ 'let*) ($ <syntax> _ (bindings ...)) body) + (expand:let* bindings body src stage env)) + ((($ <syntax> _ 'and) exps ...) + (expand:and exps src stage env)) + ((($ <syntax> _ 'or) exps ...) + (expand:or exps src stage env)) + ((($ <syntax> _ 'cond) clauses ...) + (expand:cond clauses src stage env)) + ((($ <syntax> _ 'case) key clauses ...) + (expand:case key clauses src stage env)) + ;; Function calls + ((($ <syntax> _ (? primop? op)) arguments ...) + (expand:primcall op arguments src stage env)) + ((function arguments ...) + (expand:call function arguments src stage env)) + ;; Uh oh + (_ + (seagull-syntax-error "unknown form" syntax expand*)))) + +(define (expand syntax stage) + (expand* syntax stage (fresh-environment))) diff --git a/chickadee/graphics/seagull/pass-infer.scm b/chickadee/graphics/seagull/pass-infer.scm new file mode 100644 index 0000000..0ac204e --- /dev/null +++ b/chickadee/graphics/seagull/pass-infer.scm @@ -0,0 +1,182 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; Walk the CPS control flow graph and solve for all of the type +;; variables using a variant of the Hindley-Milner type inference +;; algorithm extended to handle qualified types (types with +;; predicates.) GLSL is a statically typed language, but thanks to +;; type inference the user doesn't have to specify any types expect +;; for shader inputs, outputs, and uniforms. + +;; Dedicated to the memory of Ian Denhardt (zenhack), who pointed me +;; towards type predicate systems and answered my questions on the +;; fediverse. That was the critical piece that I, someone who knows +;; little about static typing, needed to extend traditional +;; Hindley-Milner type inference to work with GLSL's function +;; overloading. +(define-module (chickadee graphics seagull pass-infer) + #:use-module (chickadee graphics seagull cps) + #:use-module (chickadee graphics seagull primitives) + #:use-module (chickadee graphics seagull syntax) + #:use-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (language cps intmap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:export (infer)) + +(define bool (lookup-type 'bool)) +(define int (lookup-type 'int)) + +(define &seagull-type-error + (make-exception-type '&seagull-type-error &error '())) + +(define make-seagull-type-error + (record-constructor &seagull-type-error)) + +(define (seagull-type-error msg args src origin) + (raise-exception + (make-exception + (make-seagull-type-error) + (make-exception-with-origin origin) + (make-exception-with-message + (format #f "seagull type error at ~a: ~a" + (sourcev->string src) + msg)) + (make-exception-with-irritants args)))) + +(define (infer:values vals graph env subs) + (values graph + (map (lambda (var) (lookup var env)) vals) + subs)) + +(define (infer:assignment var val graph env subs) + (let ((subs* (unify (lookup var env) (lookup val env)))) + (values graph '() (compose-substitutions subs subs*)))) + +(define (infer:primitive-call op args graph env subs) + (let* ((return-types (list (fresh-type-variable))) + (call-type (make-function-type + (map (lambda (arg) (lookup arg env)) args) + return-types)) + (call-subs (unify call-type (primitive-operator-type op))) + (subs* (compose-substitutions subs call-subs))) + (values graph (substitute-types subs* return-types) subs*))) + +(define (infer* graph k types result-types env subs) + (define (type-mismatch-handler src e) + (let ((args (exception-args e))) + (match args + (((a ...) (b ...)) + (seagull-type-error (format #f "expected ~a, got ~a" + (map type-name b) (map type-name a)) + args src infer*)) + ((a b) + (seagull-type-error (format #f "expected ~a, got ~a" + (type-name b) (type-name a)) + args src infer*))))) + (define (with-error-handling src thunk) + (with-exception-handler (lambda (e) (type-mismatch-handler src e)) + thunk + #:unwind? #t + #:unwind-for-type 'type-mismatch)) + (define (infer-exp exp env) + (match (pk 'infer-exp exp) + (($ <cps-constant> _ type) + (values graph (list type) subs)) + (($ <cps-values> vals) + (infer:values vals graph env subs)) + (($ <cps-assignment> var val) + (infer:assignment var val graph env subs)) + (($ <cps-primitive-call> (= lookup-primitive-operator op) args _) + (infer:primitive-call op args graph env subs)) + (($ <cps-function> body) + (infer* graph body '() '() env subs)))) + (define (infer-term term env) + (match (pk 'infer-term term) + ;; Regular continuation. + (($ <continue> src k* exp) + (with-error-handling src + (lambda () + (let-values (((graph* types* subs*) (infer-exp exp env))) + (infer* graph* k* types* result-types env subs*))))) + ;; Function exit. + (($ <return> results) + (let* ((return-types (map (lambda (var) (lookup var env)) results)) + ;; TODO: Unify with the return types of the current function. + ;;(expected-result-types result-types) + (subs* (unify return-types result-types))) + (values graph result-types (compose-substitutions subs subs*))) + (values graph types subs)) + ;; Conditional branch. + (($ <branch> src name k-conseq k-alt) + (with-error-handling src + (lambda () + ;; Type checking a branch goes like this: + ;; 1) Unify type of test variable with bool. + ;; 2) Infer types of consequent and alternate. + ;; 3) Unify types of consequent and alternate. + (let*-values (((subs1) (unify (lookup name env) bool)) + ((subs2) (compose-substitutions subs subs1)) + ((graph1 conseq-types subs3) + (infer* graph k-conseq types result-types env subs2)) + ((graph2 alt-types subs4) + (infer* graph1 k-alt types result-types env subs3)) + ((subs5) (unify conseq-types alt-types)) + ((subs6) (compose-substitutions subs4 subs5))) + (values graph2 conseq-types subs6))))))) + (pk 'subs subs) + (pk 'env env) + (match (intmap-ref graph k) + (($ <arguments> names term _) + ;; Add newly defined variables to type environment, then infer + ;; the term in that environment. + (let*-values (((env*) (fold extend env names types)) + ((graph* types* subs*) (infer-term term env*)) + ((subs2) (unify types types*))) + (pk 'term-subs subs*) + (pk 'term-types 'before types 'after types*) + (values (intmap-replace graph* k (make-arguments names term types*)) + types* + subs* + ;; (compose-substitutions subs* subs2) + ))) + (($ <function-entry> src params results start return _) + (pk 'infer-function src params results start return) + ;; We don't know the type signature yet, so params and results + ;; are all type variables. + (let* ((param-types (fresh-type-variables params)) + (result-types (fresh-type-variables results)) + (func-type (make-function-type param-types result-types)) + ;; Add params and results to type environment. + (env* (fold extend env + (append params results) + (append param-types result-types)))) + ;; Infer types of function body using new type environment. + (define-values (graph* types* subs*) + (infer* graph start types result-types env* subs)) + ;; Apply substitutions to function type. + ;; TODO: Handle polymorphism and type predicates. + (let* ((func-type* (substitute-type subs* func-type)) + (func (make-function-entry src params results start return + func-type))) + (values (intmap-replace graph* k func) + (list func-type*) + subs*)))))) + +(define (infer graph) + (infer* graph 0 '() '() (fresh-environment) no-substitutions)) diff --git a/chickadee/graphics/seagull/pass-linearize.scm b/chickadee/graphics/seagull/pass-linearize.scm new file mode 100644 index 0000000..9735a90 --- /dev/null +++ b/chickadee/graphics/seagull/pass-linearize.scm @@ -0,0 +1,256 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; The linearization pass transforms a tree of base IL objects into a +;; control flow graph of continuations. Extremely based on Guile's +;; own "CPS soup" but greatly simplified for this much simpler +;; language and also my own inability to understand something more +;; complicated. +(define-module (chickadee graphics seagull pass-linearize) + #:use-module (chickadee graphics seagull base) + #:use-module (chickadee graphics seagull cps) + #:use-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 match) + #:use-module (language cps intmap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:export (linearize)) + +;; Unique variable generation. +(define var-counter (make-parameter 0)) + +(define (reset-var-counter!) + (var-counter 0)) + +(define (next-var) + (let ((var (var-counter))) + (var-counter (+ var 1)) + var)) + +(define (fresh-var) + (next-var)) + +(define (fresh-vars lst) + (map (lambda (_x) (fresh-var)) lst)) + +(define (make-fresh-vars n) + (list-tabulate n (lambda (_i) (fresh-var)))) + +;; Unique continuation label generation +(define label-counter (make-parameter 0)) + +(define (reset-label-counter!) + (label-counter 0)) + +(define (fresh-label) + (let ((label (label-counter))) + (label-counter (+ label 1)) + label)) + +(define (num-values exp) + (match exp + ((or (? assignment?) + (? discard?)) + 0) + ((or (? constant?) + (? lexical-reference?) + (? struct-reference?) + (? array-reference?) + (? function?) + (? primitive-call?) + ($ <values> (_))) + 1) + ;; Number of values is unknown at this stage. The type inference + ;; pass will have to figure it out. + (_ #f))) + +(define (compile:constant src val graph k) + (let* ((type (type-for-constant val)) + (const (make-cps-constant val type)) + (term (make-continue src k const))) + (values graph term))) + +(define (compile:conditional src predicate consequent alternate env graph k) + (let ((branch-k (fresh-label)) + (consequent-k (fresh-label)) + (alternate-k (fresh-label))) + (let*-values (((graph1 predicate-term) + (compile-cps predicate env graph branch-k)) + ((graph2 consequent-term) + (compile-cps consequent env graph1 k)) + ((graph3 alternate-term) + (compile-cps alternate env graph2 k))) + (let* ((branch-var (fresh-var)) + (branch-term (make-branch src branch-var consequent-k alternate-k)) + (branch-cont (make-arguments (list branch-var) branch-term #f)) + (consequent-cont (make-arguments '() consequent-term #f)) + (alternate-cont (make-arguments '() alternate-term #f))) + (values (intmap-add (intmap-add (intmap-add graph3 branch-k branch-cont) + consequent-k consequent-cont) + alternate-k alternate-cont) + predicate-term))))) + +;; Converting a linear sequence of expressions to continuation passing +;; style requires an algorithm written in continuation passing style. +;; We have to traverse to the end of the list, and then chain together +;; the continuations as the algorithm works backwards. +(define (compile:arguments exps env graph return) + (match exps + (() + (return '() graph)) + ((exp . rest) + (let*-values (((name) (fresh-var)) + ((graph* next-term) + (compile:arguments rest env graph + (lambda (names graph) + (return (cons name names) graph)))) + ((k) (fresh-label)) + ((cont) (make-arguments (list name) next-term #f)) + ((graph** this-term) + (compile-cps exp env graph* k))) + (values (intmap-add graph** k cont) + this-term))))) + +(define (compile:primitive-call src name args env graph k) + (compile:arguments args env graph + (lambda (vars graph*) + (let* ((type (fresh-type-variable)) + (prim (make-cps-primitive-call name vars type)) + (term (make-continue src k prim))) + (values graph* term))))) + +(define (compile:let src names exps body env graph k) + (compile:arguments exps env graph + (lambda (vars graph*) + (let ((env* (fold extend env names vars))) + (compile-cps body env* graph* k))))) + +(define (compile:lexical-reference src name env graph k) + (let ((vals (make-cps-values (list (lookup name env))))) + (values graph (make-continue src k vals)))) + +(define (compile:assignment src name value env graph k) + (pk 'assignment name value) + (let ((k* (fresh-label)) + (var (lookup name env))) + (let*-values (((graph* term) + (compile-cps value env graph k*))) + (let* ((val (fresh-var)) + (assign (make-cps-assignment var val)) + (term* (make-continue src k assign)) + (cont (make-arguments (list val) term* #f))) + (values (intmap-add graph* k* cont) term))))) + +(define (compile:sequence exps env graph k) + ;; (match exps + ;; (() + ;; (return '() graph)) + ;; ((exp . rest) + ;; (let*-values (((names) (and=> (num-values exp) make-fresh-vars)) + ;; ((graph* next-term) + ;; (compile:arguments rest env graph + ;; (lambda (graph) + ;; (return graph)))) + ;; ((k) (fresh-label)) + ;; ((cont) (make-arguments (list name) next-term #f)) + ;; ((graph** this-term) + ;; (compile-cps exp env graph* k))) + ;; (values (intmap-add graph** k cont) + ;; this-term)))) + + (match exps + ((exp) + (pk 'seq exp) + (compile-cps exp env graph k)) + ((exp . rest) + (pk 'seq exp) + (let ((vars (pk 'seq-vars (and=> (pk 'num-values exp (num-values exp)) make-fresh-vars)))) + (let-values (((graph* term) + (compile:sequence rest env graph k))) + (let* ((k* (fresh-label)) + (cont (make-arguments vars term #f))) + (compile-cps exp env (intmap-add graph* k* cont) k*))))))) + +'((0 . (arguments () (continue 4 (constant 1)))) + (1 . (arguments (2) (return 2))) + (2 . (arguments () (continue 1 (values 0)))) + (3 . (arguments (1) (continue 2 (assignment 0 1)))) + (4 . (arguments (0) (continue 3 (constant 2))))) + +(define (compile-cps exp env graph k) + (match (pk 'compile exp) + (($ <constant> src val) + (compile:constant src val graph k)) + (($ <conditional> src predicate consequent alternate) + (compile:conditional src predicate consequent alternate env graph k)) + (($ <primitive-call> src name args) + (compile:primitive-call src name args env graph k)) + (($ <sequence> src exps) + (compile:sequence exps env graph k)) + (($ <let> src _ names exps body) + (compile:let src names exps body env graph k)) + (($ <lexical-reference> src _ name) + (compile:lexical-reference src name env graph k)) + (($ <assignment> src _ name value) + (compile:assignment src name value env graph k)))) + +;; (define (term-arity term) +;; (define (exp-arity exp) +;; (match exp +;; (($ <cps-constant> _ _) +;; 1) +;; (($ <cps-assignment> _ _) +;; 0))) +;; (match term +;; (($ <continue> _ _ exp) +;; (exp-arity exp)) +;; (($ )))) + +(define-syntax intmap-add* + (syntax-rules () + ((_ intmap) intmap) + ((_ intmap (i v) rest ...) + (intmap-add (intmap-add* intmap rest ...) i v)))) + +(define (linearize exp) + (parameterize ((var-counter 0) + (label-counter 0)) + ;; The initial continuation is always at index 0. + (let* ((init-label (fresh-label)) + (func-return-label (fresh-label))) + (let-values (((graph term) + (compile-cps exp (fresh-environment) empty-intmap func-return-label))) + (let* ((func-start-label (fresh-label)) + (func-label (fresh-label)) + (end-label (fresh-label)) + (params '()) + (results (list (fresh-var))) + (init-term (make-continue #f end-label (make-cps-function func-label))) + (init-cont (make-arguments '() init-term #f)) + (func-cont (make-function-entry #f params results func-start-label func-return-label #f)) + (func-start-cont (make-arguments '() term #f)) + (func-return-term (make-return results)) + (func-return-cont (make-arguments results func-return-term #f)) + (end-results (list (fresh-var))) + (end-term (make-return '())) + (end-cont (make-arguments end-results end-term #f))) + (intmap-add* graph + (init-label init-cont) + (func-label func-cont) + (func-start-label func-start-cont) + (func-return-label func-return-cont) + (end-label end-cont))))))) diff --git a/chickadee/graphics/seagull/primitives.scm b/chickadee/graphics/seagull/primitives.scm new file mode 100644 index 0000000..dc74a5f --- /dev/null +++ b/chickadee/graphics/seagull/primitives.scm @@ -0,0 +1,142 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (chickadee graphics seagull primitives) + #:use-module (chickadee graphics seagull base) + #:use-module (chickadee graphics seagull syntax) + #:use-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (make-primitive-operator + define-primitive-operator + lookup-primitive-operator + primitive-operator? + primitive-operator-name + primitive-operator-glsl-name + primitive-operator-stages + primitive-operator-arity + primitive-operator-expand + primitive-operator-infix? + primitive-operator-type)) + +(define-record-type <primitive-operator> + (%make-primitive-operator name glsl-name stages arity expand infix? type) + primitive-operator? + (name primitive-operator-name) + (glsl-name primitive-operator-glsl-name) + (stages primitive-operator-stages) + (arity primitive-operator-arity) + (expand primitive-operator-expand) + (infix? primitive-operator-infix?) + (type primitive-operator-type)) + +(define (make-default-expander name) + (lambda (args src expand) + (make-primitive-call src name (map expand args)))) + +(define* (make-primitive-operator #:key name type proc arity + (glsl-name name) + (stages (list stage:vertex stage:fragment)) + (expand (make-default-expander name)) + infix?) + (%make-primitive-operator name glsl-name stages arity expand infix? type)) + +(define *primitive-operators* (make-hash-table)) + +(define (register-primitive-operator! primitive-operator) + (hashq-set! *primitive-operators* + (primitive-operator-name primitive-operator) + primitive-operator) + *unspecified*) + +(define (lookup-primitive-operator name) + (hashq-ref *primitive-operators* name)) + +(define-syntax-rule (define-primitive-operator name args ...) + (register-primitive-operator! + (make-primitive-operator #:name 'name args ...))) + +(define int (lookup-type 'int)) +(define -> make-function-type) + +(define-primitive-operator + + #:arity 2 + #:type (-> (list int int) (list int)) + #:infix? #t + #:expand + (lambda (args src expand) + (let loop ((args args)) + (match args + (() + (make-constant src 0)) + ((n) + (expand n)) + ((n . rest) + (make-primitive-call src '+ (list (expand n) (loop rest)))))))) + +(define-primitive-operator - + #:arity 2 + #:type (-> (list int int) (list int)) + #:infix? #t + #:expand + (lambda (args src expand) + (let loop ((args args)) + (match args + ((n) (make-primitive-call src '- (list (expand n) (make-constant src 0)))) + ((m n) + (make-primitive-call src '- (list (expand m) (expand n)))) + ((n . rest) + (make-primitive-call src '- (list (expand n) (loop rest)))))))) + +(define-primitive-operator * + #:arity 2 + #:type (-> (list int int) (list int)) + #:infix? #t + #:expand + (lambda (args src expand) + (let loop ((args args)) + (match args + (() (make-constant src 1)) + ((n) (expand n)) + ((n . rest) + (make-primitive-call src '* (list (expand n) (loop rest)))))))) + +(define-primitive-operator / + #:arity 2 + #:type (-> (list int int) (list int)) + #:infix? #t + #:expand + (lambda (args src expand) + (match args + ((n) + (make-primitive-call src '/ (list (make-constant src 1) (expand n)))) + ((m n) + (make-primitive-call src '/ (list (expand m) (expand n)))) + ((m n . rest) + (let loop ((rest rest) + (exp (make-primitive-call src '/ (list (expand m) (expand n))))) + (match rest + ((l) + (make-primitive-call src '/ (list exp (expand l)))) + ((l . rest) + (loop rest (make-primitive-call src '/ (list exp (expand l))))))))))) + +(define-primitive-operator = #:arity 2 #:infix? #t) + +(define-primitive-operator vec2 #:arity 2) +(define-primitive-operator vec3 #:arity 3) +(define-primitive-operator vec4 #:arity 4) diff --git a/chickadee/graphics/seagull/syntax.scm b/chickadee/graphics/seagull/syntax.scm new file mode 100644 index 0000000..81876b4 --- /dev/null +++ b/chickadee/graphics/seagull/syntax.scm @@ -0,0 +1,95 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (chickadee graphics seagull syntax) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (system syntax internal) + #:export (<syntax> + make-seagull-syntax + seagull-syntax? + seagull-syntax-source + seagull-syntax-expression + seagull-syntax->sexp + build-syntax + $gl + &seagull-syntax-error + seagull-syntax-error + seagull-syntax-error-syntax)) + +(define-record-type <syntax> + (make-seagull-syntax source exp) + seagull-syntax? + (source seagull-syntax-source) + (exp seagull-syntax-expression)) + +(define (seagull-syntax->sexp syntax) + (match (seagull-syntax-expression syntax) + ((children ...) + (map seagull-syntax->sexp children)) + (atom atom))) + +(define (build-syntax src exp) + (match exp + ((? seagull-syntax?) + exp) + ((children ...) + (make-seagull-syntax src + (map (lambda (child) + (build-syntax src child)) + children))) + (atom + (make-seagull-syntax src atom)))) + +;; Annotate seagull expressions with source information, producing +;; seagull-specific syntax objects that can't be confused with scheme +;; syntax objects. +(define-syntax $gl + (lambda (x) + (syntax-case x () + ((_ exp) + (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp)))) + #'(make-seagull-syntax src ($gl-recur exp))))))) + +;; Helper macro to annotate nested expressions. +(define-syntax $gl-recur + (syntax-rules () + ((_ (item ...)) + (list ($gl item) ...)) + ((_ atom) + 'atom))) + +(define &seagull-syntax-error + (make-exception-type '&seagull-syntax-error &error '(syntax))) + +(define make-seagull-syntax-error + (record-constructor &seagull-syntax-error)) + +(define seagull-syntax-error-syntax + (exception-accessor &seagull-syntax-error + (record-accessor &seagull-syntax-error 'syntax))) + +(define (seagull-syntax-error msg syntax origin) + (raise-exception + (make-exception + (make-seagull-syntax-error syntax) + (make-exception-with-origin origin) + (make-exception-with-message + (format #f "Syntax error at ~a: ~a" + (sourcev->string (seagull-syntax-source syntax)) + msg)) + (make-exception-with-irritants (list (seagull-syntax->sexp syntax)))))) diff --git a/chickadee/graphics/seagull/types.scm b/chickadee/graphics/seagull/types.scm new file mode 100644 index 0000000..095d1a8 --- /dev/null +++ b/chickadee/graphics/seagull/types.scm @@ -0,0 +1,337 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +;; The Seagull static type system. +(define-module (chickadee graphics seagull types) + #:use-module (chickadee graphics seagull utils) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (lookup-type + base-type-environment + + type-variable-counter + fresh-type-variable + fresh-type-variables + make-type-variable + type-variable? + type-variable-id + + primitive-type? + primitive-type-name + primitive-type-glsl-name + + <function-type> + make-function-type + function-type? + function-type-parameters + function-type-returns + + type? + type-name + type-glsl-name + type-for-constant + + make-substitutions + substitutions? + unbox-substitutions + no-substitutions + add-substitution + substitute-type + substitute-types + compose-substitutions + occurs? + unify)) + + +;;; +;;; Built-in type registry +;;; + +(define *types* (make-hash-table)) + +(define (lookup-type name) + (hashq-ref *types* name)) + +(define (register-type! name type) + (hashq-set! *types* name type)) + +(define (base-type-environment) + (hash-fold extend (fresh-environment) *types*)) + + +;;; +;;; Type variables +;;; + +(define-record-type <type-variable> + (make-type-variable id) + type-variable? + (id type-variable-id)) + +(set-record-type-printer! <type-variable> + (lambda (tvar port) + (format port "#<type-variable ~a>" + (type-variable-id tvar)))) + +(define type-variable-counter (make-parameter 0)) + +(define (fresh-type-variable) + (let ((id (type-variable-counter))) + (type-variable-counter (+ id 1)) + (make-type-variable id))) + +(define (fresh-type-variables lst) + (map (lambda (_x) (fresh-type-variable)) lst)) + + +;;; +;;; Primitive types +;;; + +(define-record-type <primitive-type> + (make-primitive-type name glsl-name) + primitive-type? + (name primitive-type-name) + (glsl-name primitive-type-glsl-name)) + +(set-record-type-printer! <primitive-type> + (lambda (t port) + (format port "#<primitive-type ~a>" + (primitive-type-name t)))) + +(define-syntax define-primitive-type + (syntax-rules () + ((_ name) + (register-type! 'name (make-primitive-type 'name (symbol->string 'name)))) + ((_ name glsl-name) + (register-type! 'name (make-primitive-type 'name glsl-name))))) + +(define-primitive-type bool) +(define-primitive-type int) +(define-primitive-type float) +(define-primitive-type mat3) +(define-primitive-type mat4) +(define-primitive-type sampler-2d "sampler2D") + + +;;; +;;; Structs +;;; + +(define-record-type <struct-field> + (%make-struct-field name glsl-name type) + struct-field? + (name struct-field-name) + (glsl-name struct-field-glsl-name) + (type struct-field-type)) + +(define* (make-struct-field name type #:key (glsl-name (symbol->string name))) + (%make-struct-field name glsl-name type)) + +(define-record-type <struct> + (make-struct name glsl-name fields) + struct? + (name struct-name) + (glsl-name struct-glsl-name) + (fields struct-fields)) + +(define-syntax define-struct + (syntax-rules () + ((_ (name glsl-name) (field-name field-type field-opt ...) ...) + (register-type! 'name + (make-struct 'name glsl-name + (list + (make-struct-field 'field-name + (lookup-type 'field-type) + field-opt ...) + ...)))) + ((_ name fields ...) + (define-struct (name (symbol->string 'name)) fields ...)))) + +(define-struct vec2 + (x float) + (y float)) + +(define-struct vec3 + (x float) + (y float) + (z float)) + +(define-struct vec4 + (x float) + (y float) + (z float) + (w float)) + + +;;; +;;; Function type +;;; + +(define-record-type <function-type> + (make-function-type parameters returns) + function-type? + (parameters function-type-parameters) + (returns function-type-returns)) + + +;;; +;;; Utils +;;; + +(define (type? obj) + (or (primitive-type? obj))) + +(define (type-name type) + (match type + (($ <primitive-type> _ name) name) + (($ <function-type> params results) + (format #f "(-> ~a ~a)" + (map type-name params) + (map type-name results))) + (($ <type-variable> id) + (format #f "tvar-~a" id)))) + +(define (type-glsl-name type) + (match type + (($ <primitive-type> _ name) name) + ;; TODO: Remove this eventually. + (($ <type-variable> id) + (format #f "t~a" id)))) + +(define (type-for-constant x) + (lookup-type + (cond + ((boolean? x) 'bool) + ((exact-integer? x) 'int) + ((float? x) 'float)))) + + +;;; +;;; Unification +;;; + +(define-record-type <substitutions> + (make-substitutions subs) + substitutions? + (subs unbox-substitutions)) + +(define no-substitutions (make-substitutions '())) + +(define (add-substitution subs a b) + (make-substitutions (alist-cons a b (unbox-substitutions subs)))) + +(define (%substitute-type type from to) + (cond + ((primitive-type? type) + type) + ((type-variable? type) + (if (eq? type from) to type)))) + +(define (substitute-type subs type) + (fold (lambda (pair type*) + (match pair + ((from . to) + (%substitute-type type* from to)))) + type + (unbox-substitutions subs))) + +(define (substitute-types subs types) + (map (lambda (type) + (substitute-type subs type)) + types)) + +(define (compose-substitutions a b) + (define b* + (map (match-lambda + ((from . to) + (cons from (substitute-type a to)))) + (unbox-substitutions b))) + (define a* + (filter-map (match-lambda + ((from . to) + (if (assq-ref b* from) + #f + (cons from to)))) + (unbox-substitutions a))) + (make-substitutions (append a* b*))) + +(define (occurs? a b) + "Return #t if type A appears in type B." + (define (a-occurs? b*) + (occurs? a b*)) + (cond + ((and (type-variable? a) (type-variable? b)) + (eq? a b)) + ((and (type-variable? a) (function-type? b)) + (or (any a-occurs? (function-type-parameters b)) + (any a-occurs? (function-type-returns b)))) + (else #f))) + +(define (type-mismatch a b) + (throw 'type-mismatch a b)) + +(define (unify:primitives a b) + (if (eq? a b) + no-substitutions + (type-mismatch a b))) + +(define (unify:variable a b) + (cond + ((eq? a b) + no-substitutions) + ((occurs? a b) + (type-mismatch a b)) + (else + (add-substitution no-substitutions a b)))) + +(define (unify:functions a b) + (define param-subs + (unify (function-type-parameters a) + (function-type-parameters b))) + (define return-subs + (unify (substitute-types param-subs + (function-type-returns a)) + (substitute-types param-subs + (function-type-returns b)))) + (compose-substitutions param-subs return-subs)) + +(define (unify:pair a b) + (define car-subs (unify (car a) (car b))) + (define cdr-subs (unify (substitute-types car-subs (cdr a)) + (substitute-types car-subs (cdr b)))) + (compose-substitutions car-subs cdr-subs)) + +(define (unify a b) + "Return a list of substitutions that unify types A and B, or throw an +error if A and B are incompatible." + (cond + ((and (primitive-type? a) (primitive-type? b)) + (unify:primitives a b)) + ((type-variable? a) + (unify:variable a b)) + ((type-variable? b) + (unify:variable b a)) + ((and (function-type? a) (function-type? b)) + (unify:functions a b)) + ((and (null? a) (null? b)) + no-substitutions) + ((and (pair? a) (pair? b)) + (unify:pair a b)) + (else + (type-mismatch a b)))) diff --git a/chickadee/graphics/seagull/utils.scm b/chickadee/graphics/seagull/utils.scm new file mode 100644 index 0000000..af155a6 --- /dev/null +++ b/chickadee/graphics/seagull/utils.scm @@ -0,0 +1,124 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu> +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (chickadee graphics seagull utils) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (language cps intmap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (float? + sourcev->string + stage:vertex + stage:fragment + shader-stage? + vertex-stage? + fragment-stage? + + environment? + fresh-environment + environment + bound? + lookup + extend + compose-environments + + intmap->alist + alist->intmap)) + +(define (float? x) + (and (number? x) (inexact? x))) + +(define (sourcev->string sourcev) + (match sourcev + (#f + "unknown location") + (#(#f line column) + (format #f "unknown:~a:~a" line column)) + (#(file line column) + (format #f "~a:~a:~a" file line column)))) + + +;;; +;;; Shader stages +;;; + +(define-record-type <shader-stage> + (shader-stage name) + shader-stage? + (name shader-stage-name)) + +(define stage:vertex (shader-stage 'vertex)) +(define stage:fragment (shader-stage 'fragment)) + +(define (vertex-stage? obj) + (eq? obj stage:vertex)) + +(define (fragment-stage? obj) + (eq? obj stage:fragment)) + + +;;; +;;; Environments +;;; + +;; Environments provide a lookup table. Used for lexical scoping, +;; alpha conversion, etc. +(define-record-type <environment> + (make-environment bindings) + environment? + (bindings environment-bindings)) + +(define (fresh-environment) + (make-environment '())) + +(define-syntax-rule (environment (key value) ...) + (make-environment (list (cons 'key value) ...))) + +(define (lookup name env) + (assq-ref (environment-bindings env) name)) + +(define (bound? name env) + (not (not (lookup name env)))) + +(define (extend name value env) + (make-environment + (alist-cons name value (environment-bindings env)))) + +(define (compose-environments . envs) + (match envs + ((a b) + (make-environment + (append (environment-bindings a) + (environment-bindings b)))) + (_ + (make-environment + (concatenate + (map environment-bindings envs)))))) + + +;;; +;;; Intmap helpers +;;; + +(define (intmap->alist intmap) + (intmap-fold-right alist-cons intmap '())) + +(define (alist->intmap alist) + (fold (lambda (pair intmap) + (match pair + ((k . v) + (intmap-add intmap k v)))) + empty-intmap alist)) diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm index 85033d7..288e6bb 100644 --- a/chickadee/graphics/sprite.scm +++ b/chickadee/graphics/sprite.scm @@ -62,17 +62,15 @@ (in vec2 tex) (out vec2 frag-tex) (uniform mat4 mvp) - (outputs - (vertex:position (* mvp (vec4 position 0.0 1.0))) - (frag-tex tex))) + (set! vertex:position (* mvp (vec4 position 0.0 1.0))) + (set! frag-tex tex)) (define-fragment-shader sprite-fragment (in vec2 frag-tex) (out vec4 frag-color) (uniform sampler-2d color-texture) (uniform vec4 tint) - (outputs - (frag-color (* (texture color-texture frag-tex) tint)))) + (set! frag-color (* (texture color-texture frag-tex) tint))) (define-graphics-variable sprite-shader (compile-shader sprite-vertex sprite-fragment)) |