diff options
Diffstat (limited to 'chickadee/graphics/seagull')
| -rw-r--r-- | chickadee/graphics/seagull/base.scm | 313 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/cps.scm | 306 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/glsl.scm | 151 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/pass-expand.scm | 310 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/pass-infer.scm | 182 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/pass-linearize.scm | 256 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/primitives.scm | 142 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/syntax.scm | 95 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/types.scm | 337 | ||||
| -rw-r--r-- | chickadee/graphics/seagull/utils.scm | 124 |
10 files changed, 2216 insertions, 0 deletions
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)) |