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 to-pass metakont kont)
  cps-apply-kont?
  cps-apply-kont=>
  (to-pass %apply-kont:to-pass)
  (metakont %apply-kont:metakont)
  (kont %apply-kont:kont))

(define-record-type/destructor <cps-apply>
  (cps-apply proc formal metakont kont)
  cps-apply?
  cps-apply=>
  (proc %apply:proc)
  (formal %apply:formal)
  (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
    (after ((let (cps-kappa=> form) => (metakont formal cps-cmd)))
      `(kappa ,formal ,metakont ,(cps->sexpr cps-cmd)))
    (after ((let (cps-closure=> form)
              => (formal metakont-formal kont-formal body)))
      `(lambda ((,metakont-formal ,kont-formal) ,formal)
         ,(cps->sexpr body)))
    (after ((let (cps-apply-kont=> form) => (to-pass metakont kont)))
      (let ((to-pass (if (cps-closure? to-pass)
                         (cps->sexpr to-pass)
                         to-pass)))
        `(pass ,to-pass ,metakont ,(cps->sexpr kont))))
    (after ((let (cps-apply=> form) => (proc formal metakont kont)))
      `(apply ,proc ,formal ,metakont ,(cps->sexpr kont)))
    (after ((let (cps-if=> form)
              => (conditional on-true on-false metakont kont)))
      `(if conditional
           ,(cps->sexpr on-true)
           ,(cps->sexpr on-false)
           metakont
           ,(cps->sexpr kont)))
    (when-ct (or (self-evaluating? form) (symbol? 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+γ↑
                                                '__κ0
                                                'γ↓)))))

(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
                          '__κ0))
               (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
                          '__κ0))
               (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
           (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))