path: root/cps.scm

#| Copyright (c) Peter McGoron 2024
 |
 | This Source Code Form is subject to the terms of the Mozilla Public
 | License, v. 2.0. If a copy of the MPL was not distributed with this
 | file, You can obtain one at https://mozilla.org/MPL/2.0/.
 |-------------------------------------------------------------------------
 | Gamma Scheme has the following core:
 |
 |     EXPR ::= (lambda FORMAL TAIL-EXPR)
 |            | (EXPR EXPR ...)
 |            | (if EXPR EXPR EXPR)
 |            | (quote DATA)
 |            | (push-prompt EXPR EXPR)
 |            | (push-sub-continuation EXPR EXPR)
 |            | LITERAL | SYMBOL
 |
 | The delimited continuation operators are from Dyvbig, Peyton Jones,
 | and Sabry (2007). These are the only syntatic constructs: `new-prompt`
 | and `with-sub-continuation` are implemented as primitive functions.
 |
 | All continuations can take multiple values.
 |#

;;; Handling objects that can be evaluated in one step. These are
;;; 1) quotes
;;; 2) symbols (look up in environment)
;;; 3) self evaluating objects (booleans, numbers, etc.)

(define (quote=> x)
  (cond-values
    (after ((let (pair=> x) => (head tail))
           (when (eq? head 'quote))
           (on-fail! (error "invalid quote" x))
           (let (length=> tail 1) => (form)))
      form)))

(define (self-evaluating? form)
  (or (number? form) (string? form) (null? form) (vector? form)
      (boolean? form) (bytevector? form)))

(define (constant=> form)
  ;; If `form` is either self evaluating, or is a quote of something
  ;; that is constantly evaluating, return the self evaluated object.
  (cond-values
    (when-ct (self-evaluating? form)
      form)
    (after ((let (quote=> form) => (form))
            (when (self-evaluating? form)))
      form)
    (after ((let (quote=> form) => _))
      form)))

(define (simple-evaluate=> form)
  ;; If `form` can be evaluated at this time, return `form` evaluated.
  ;; If `form` can be evaluated in one step (lookup the value in the
  ;; scope), then return the symbol.
  (cond-values
    (after ((let (constant=> form) => (form)))
      form)
    (when-ct (symbol? form)
      form)))

;;; Compound CPS objects

(define-record-type/destructor <cps-kappa>
  (cps-kappa metakont formal cps-cmd)
  cps-kappa?
  cps-kappa=>
  (metakont %kappa:get-metakont)
  (formal %kappa:get-formal)
  (cps-cmd %kappa:get-cps-cmd))

(define-record-type/destructor <cps-closure>
  (cps-closure formal metakont-formal kont-formal body)
  cps-closure?
  cps-closure=>
  (formal %closure:formal)
  (metakont-formal %closure:metakont-formal)
  (kont-formal %closure:kont-formal)
  (body %closure:body))

;;; These are all CPS commands. The `metakont` field is the
;;; metacontinuation passed to the continuation `kont`. The preceeding
;;; arguments are related to the object that is passed to `kont`.

(define-record-type/destructor <cps-apply-kont>
  (cps-apply-kont args metakont kont)
  cps-apply-kont?
  cps-apply-kont=>
  (args %apply-kont:args)
  (metakont %apply-kont:metakont)
  (kont %apply-kont:kont))

(define-record-type/destructor <cps-apply>
  (cps-apply proc args metakont kont)
  cps-apply?
  cps-apply=>
  (proc %apply:proc)
  (args %apply:args)
  (metakont %apply:metakont)
  (kont %apply:kont))

(define-record-type/destructor <cps-if>
  (cps-if conditional on-true on-false metakont kont)
  cps-if?
  cps-if=>
  (conditional %cps-if:conditional)
  (on-true %cps-if:on-true)
  (on-false %cps-if:on-false)
  (metakont %cps-if:metakont)
  (kont %cps-if:kont))

(define (cps->sexpr form)
  (cond-thunk
    (receive-ct (metakont formal cps-cmd) (cps-kappa=> form)
      `(kappa ,formal ,metakont ,(cps->sexpr cps-cmd)))
    (receive-ct (formal metakont-formal kont-formal body)
                (cps-closure=> form)
      `(lambda ((,metakont-formal ,kont-formal) ,formal)
         ,(cps->sexpr body)))
    (receive-ct (args metakont kont) (cps-apply-kont=> form)
      (let ((args (if (symbol? args)
                      args
                      (map cps->sexpr args))))
        `(pass ,args ,metakont ,(cps->sexpr kont))))
    (receive-ct (proc args metakont kont) (cps-apply=> form)
      (let ((args (if (symbol? args)
                      args
                      (map cps->sexpr args))))
        `(apply ,proc ,args ,metakont ,(cps->sexpr kont))))
    (receive-ct (conditional on-true on-false metakont kont) (cps-if=> form)
      `(if conditional
           ,(cps->sexpr on-true)
           ,(cps->sexpr on-false)
           metakont
           ,(cps->sexpr kont)))
    (receive-ct _ (simple-evaluate=> form)
      form)
    (else (error "invalid form" form))))

(define cps:with-sub-kont
  (cps-closure '(prompt proc) 'γ 'κ
               (cps-apply '__split-γ
                          '(kont γ prompt)
                          'γ
                          (cps-kappa 'discarded
                                     '(kont+γ↑ γ↓)
                                     (cps-apply 'proc
                                                'kont+γ↑
                                                '__unwind
                                                'γ↓)))))

(define (core->cps form)
  (define gensym
    (let ((x 0))
      (lambda (template)
        (set! x (+ x 1))
        (string->symbol (string-append "__"
                                       template
                                       (number->string x))))))
  (define (core->cps form metakont kont)
    (cond-thunk
      (after ((let (simple-evaluate=> form) => (form)))
        (cps-apply-kont (list form) metakont kont))
      ;; (push-prompt e e)
      (after ((let (pair=> form) => (head tail))
              (when (eq? head 'push-prompt))
              (on-fail! (error "invalid push-prompt" form))
              (let (length=> tail 2) => (prompt-part expr-part)))
        (let* ((new-prompt (gensym "p"))
               (new-metakont (gensym "γ"))
               (cons*-metakont (gensym "γ"))
               (cps-expr (core->cps
                          expr-part
                          cons*-metakont
                          '__unwind))
               (cons*-expr (cps-apply
                            'cons*
                            (list new-prompt kont new-metakont)
                            new-metakont
                            (cps-kappa 'ignored
                                       (list cons*-metakont)
                                       cps-expr))))
          (core->cps prompt-part metakont
                     (cps-kappa new-metakont
                                (list new-prompt)
                                cons*-expr))))
      ;; (push-sub-cont e e)
      (after ((let (pair=> form) => (head tail))
              (when (eq? head 'push-sub-continuation))
              (on-fail! (error "invalid push-sub-cont" form))
              (let (length=> tail 2) => (sub-cont-part expr-part)))
        (let* ((sub-cont-reified (gensym "γ"))
               (sub-cont-from-eval (gensym "γ"))
               (in-middle-sub-cont (gensym "γ"))
               (cps-expr (core->cps
                          expr-part
                          in-middle-sub-cont
                          '__unwind))
               (in-middle-expr (cps-apply
                                'in-middle
                                (list sub-cont-reified
                                      kont
                                      sub-cont-from-eval)
                                sub-cont-from-eval
                                (cps-kappa 'ignored
                                           (list in-middle-sub-cont)
                                           cps-expr)))
               )
          (core->cps sub-cont-part
                     metakont
                     (cps-kappa sub-cont-from-eval
                                sub-cont-reified
                                in-middle-expr))))
      ;; (lambda formal expr)
      (after ((let (pair=> form) => (head tail))
              (when (eq? head 'lambda))
              (on-fail! (error "invalid lambda" form))
              (let (length=> tail 2) => (formal expr)))
        (let ((metakont-formal (gensym "γ"))
              (return-kont (gensym "κ")))
          (cps-apply-kont
           (list
            (cps-closure formal metakont-formal return-kont
                         (core->cps expr metakont-formal return-kont)))
           metakont
           kont)))
      ;; (if e e e)
      (after ((let (pair=> form) => (head tail))
              (when (eq? head 'if))
              (on-fail! (error "invalid if" form))
              (let (length=> tail 3) => (the-cond on-true on-false)))
        (cond-thunk
          (after ((let (constant=> the-cond) => (the-cond)))
            (if the-cond
                (core->cps on-true metakont kont)
                (core->cps on-false metakont kont)))
          (else
           (let* ((metakont-cond (gensym "γ"))
                  (kont-each (gensym "κ"))
                  (cond-evaled (gensym "v"))
                  (branch (lambda (expr)
                            (cps-kappa metakont-cond
                                       kont-each
                                       (core->cps expr
                                                  metakont-cond
                                                  kont-each)))))
             (core->cps the-cond
                        metakont
                        (cps-kappa metakont-cond
                                   cond-evaled
                                   (cps-if cond-evaled
                                           (branch on-true)
                                           (branch on-false)
                                           metakont-cond
                                           kont-each)))))))
      ;; (e e ...)
      (after ((when (pair? form)))
        (let compile ((build-call '())
                      (to-do form)
                      (metakont metakont))
          (cond-thunk
            (after ((let (pair=> to-do) => (expr to-do)))
              (cond-thunk
                (after ((let (simple-evaluate=> expr) => (expr)))
                  (compile (cons expr build-call) to-do metakont))
                (else
                 (let ((new-metakont (gensym "γ"))
                       (new-formal (gensym "v")))
                   (core->cps expr
                              metakont
                              (cps-kappa new-metakont
                                         (list new-formal)
                                         (compile (cons new-formal
                                                        build-call)
                                                  to-do
                                                  new-metakont)))))))
            (else (let ((build-call (reverse build-call)))
                    (cps-apply (car build-call)
                               (cdr build-call)
                               metakont
                               kont))))))
      (else (error "invalid core form" form))))
  (core->cps form '() '__toplevel))

(define (empty-map)
  (mapping (make-default-comparator)))

(define (formal-set-many mapping keys vals)
  ;; KEYS is either an improper list or a proper list of symbols: it is
  ;; the formals that are being bound.
  ;; 
  ;; If KEYS is a proper list, then it must have the same length as VALS.
  ;; 
  ;; If KEYS is an improper list, then the amount of elements in VALS must
  ;; be greater than or equal to the amount of elements in the proper part
  ;; of KEYS.
  (cond
    ((and (null? keys) (null? vals)) mapping)
    ((symbol? keys)
     (mapping-set mapping keys vals))
    ((or (null? keys) (null? vals)) (error "unbalanced" mapping keys vals))
    (else (formal-set-many (mapping-set mapping (car keys) (car vals))
                           (cdr keys)
                           (cdr vals)))))

(define prompt? integer?)

(define special-values '(__toplevel __unwind))
(define (eval-cps dynenv lexenv tmpenv expr)
  (define envs
    (mapping-union tmpenv lexenv dynenv))
  (define (throw-error msg . others)
    (apply error msg
           (mapping->alist dynenv)
           (mapping->alist lexenv)
           (mapping->alist tmpenv)
           (cps->sexpr expr)
           others))
  (define (lookup key)
    (if (memq key special-values)
        key
        (mapping-ref envs key
                     (cut throw-error "invalid key" key))))
  (define (eval-simple expr)
    (cond
      ((symbol? expr) (lookup expr))
      (else expr)))
  (define (eval-args expr)
    (if (symbol? expr)
        (lookup expr)
        (map eval-simple expr)))
  (define (return args)
    (values args dynenv lexenv tmpenv))
  (define (unwind-metacontinuation args metakont)
    (cond-thunk
      (receive-ct (head metakont) (pair=> metakont)
        (cond
          ((prompt? head)
           (unwind-metacontinuation args metakont))
          ((cps-kappa? head)
           (eval-kont args metakont head))
          (else (throw-error "invalid in metakont" metakont))))
      (when-ct (null? metakont)
        (return args))
      (else (error "invalid metakont" metakont))))
  (define (eval-kont kont args metakont)
    (cond-thunk
      (receive-ct (new-metakont formal cps-cmd) (cps-kappa=> kont)
        (eval-cps dynenv lexenv
                  (formal-set-many tmpenv
                                   (cons new-metakont formal)
                                   (cons metakont args))
                  cps-cmd))
      (when-ct (eq? kont '__toplevel)
        (return args))
      (when-ct (eq? kont '__unwind)
        (unwind-metacontinuation metakont kont))
      (else (throw-error "unknown continuation" kont))))
  (define (eval-fun proc args metakont kont)
    (cond-thunk
      (receive-ct (formal metakont-formal kont-formal body)
                  (cps-closure=> proc)
        (eval-cps dynenv
                  (formal-set-many (empty-map)
                                   formal
                                   args)
                  (formal-set-many (empty-map)
                                   (list metakont-formal kont-formal)
                                   (list metakont kont))
                  body))
      (when-ct (procedure? proc)
        (apply proc metakont kont args))
      (else (throw-error "invalid procedure" proc))))
  (cond-thunk
    (receive-ct (args metakont kont) (cps-apply-kont=> expr)
      (eval-kont (eval-simple kont)
                 (eval-args args)
                 (eval-simple metakont)))
    (receive-ct (proc args metakont kont) (cps-apply=> expr)
      (eval-fun (eval-simple proc)
                (eval-args args)
                (eval-simple metakont)
                (eval-simple kont)))
    (receive-ct (conditional on-true on-false metakont kont)
                (cps-if=> expr)
      (let ((conditional (lookup conditional))
            (metakont (eval-simple metakont))
            (kont (eval-simple kont)))
        (eval-kont (if conditional on-true on-false)
                   metakont
                   kont)))
    (else (throw-error "unknown command" expr))))

(define (eval-core expr)
  (eval-cps (empty-map) (empty-map) (empty-map)
            (core->cps expr)))