summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am34
-rw-r--r--chickadee/graphics/seagull.scm3814
-rw-r--r--chickadee/graphics/seagull/base.scm313
-rw-r--r--chickadee/graphics/seagull/cps.scm306
-rw-r--r--chickadee/graphics/seagull/glsl.scm151
-rw-r--r--chickadee/graphics/seagull/pass-expand.scm310
-rw-r--r--chickadee/graphics/seagull/pass-infer.scm182
-rw-r--r--chickadee/graphics/seagull/pass-linearize.scm256
-rw-r--r--chickadee/graphics/seagull/primitives.scm142
-rw-r--r--chickadee/graphics/seagull/syntax.scm95
-rw-r--r--chickadee/graphics/seagull/types.scm337
-rw-r--r--chickadee/graphics/seagull/utils.scm124
-rw-r--r--chickadee/graphics/sprite.scm8
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))