path: root/chickadee/graphics/seagull/cps.scm

;;; 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)