diff options
Diffstat (limited to 'chickadee/graphics/seagull/cps.scm')
| -rw-r--r-- | chickadee/graphics/seagull/cps.scm | 306 |
1 files changed, 306 insertions, 0 deletions
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) |