Cleaner cps interface

scmvm/assembler.scm

@@ -6,7 +6,7 @@
   #:use-module ((scheme base) #:select (write-bytevector))
   #:export ((make-assembler* . make-assembler)
 	    assembler?
-	    assembler-pos
+	    assembler-pos assembler-pos-set!
 	    assembler-buf
 	    assembler-labels
 	    emit-label

scmvm/language/assembly.scm

@@ -13,8 +13,7 @@
 
 (define (lookup-instruction inst)
   (define inst-obj (assq (or-alias inst) *instruction-set*))
-  (if inst-obj
+  (or inst-obj
-      inst-obj
       (error (format #f "could not find instruction ~a" inst))))
 
 (define label? (negate pair?))

scmvm/language/cps.scm

@@ -1,14 +0,0 @@
-(define-module (scmvm language cps)
-  #:use-module (scmvm assembler)
-  #:use-module (ice-9 match)
-  #:export (compile-cps))
-
-(define (compile-atom asm atom)
-  (cond
-   [(number? atom) (emit-literal asm atom)]))
-
-(define (compile-cps asm soup)
-  (when (not (null? soup))
-    (match (car soup)
-      [(? (negate pair?) atom) (compile-atom asm atom)])
-    (compile-cps asm (cdr soup))))

scmvm/language/scheme.scm

@@ -0,0 +1,194 @@
+(define-module (scmvm language scheme)
+  #:use-module (scmvm assembler)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (compile decompile ir-convert))
+
+;; Scheme compiler
+;; Scheme subset we're targeting
+;; <prgm> ::= <top> ...
+;; <top>  ::= <def> | <exp>
+;; <def>  ::= (define <var> <exp>)
+;;          | (define (<var> <var> ...) <exp> ...)
+;; <exp>  ::= (lambda (<var> ...) <exp> ...)
+;;          | (if <exp> <exp> <exp>)
+;;          | (<exp> <exp> ...)
+;;          | (let ((<var> <exp>) ...) <exp> ...)
+;;          | (begin <exp> ...)
+;;          | <num> | <sym> | <var> | #t | #f
+
+(define (atomic? x)
+  (or (number? x)
+      (symbol? x)
+      (boolean? x)))
+
+(define (primitive? x)
+  (memq x '(+ - * / = < > <= >=)))
+
+(define-syntax-rule (define-cps-loop name unit)
+  (define (name v* k)
+    (if (null? v*)
+	(k '())
+	(unit (car v*)
+	      (lambda (t)
+		(name (cdr v*)
+		      (lambda (t*)
+			(k (cons t t*)))))))))
+
+;; Desugaring
+;; Transforms to simplify the language
+;; - lambdas and lets can only have 1 expression in body position
+;; - define is always simple binds, function defs bind a lambda
+;; <prgm> ::= <top> ...
+;; <top>  ::= <def> | <exp>
+;; <def>  ::= (define <var> <exp>)
+;; <exp>  ::= (lambda (<var> ...) <exp>)
+;;          | (if <exp> <exp> <exp>)
+;;          | (<exp> <exp> ...)
+;;          | (let ((<var> <exp>) ...) <exp>)
+;;          | (begin <exp> ...)
+;;          | <num> | <sym> | <var> | #t | #f
+
+(define (desugar-prgm prgm)
+  (map (lambda (top)
+	 (if (and (pair? top) (eq? (car top) 'define))
+	     (desugar-define top)
+	     (desugar-exp top)))
+       prgm))
+
+(define (desugar-define def)
+  (match def
+    [`(define ,(name params ...) . ,e*)
+     `(define ,name ,(desugar-exp `(lambda ,params ,@e*)))]
+    [`(define ,name ,exp)
+     `(define ,name ,(desugar-exp exp))]))
+
+(define (desugar-exp exp)
+  (match exp
+    [`(lambda ,params . ,body)
+     `(lambda ,params ,(desugar-body body))]
+    [`(if ,exp1 ,exp2 ,exp3)
+     `(if ,(desugar-exp exp1) ,(desugar-exp exp2) ,(desugar-exp exp3))]
+    [`(,f . ,args)
+     `(,(desugar-exp f) ,@(map desugar-exp args))]
+    [`(let ,((v* e*) ...) . ,body)
+     `(let (,(map (lambda (v e) `(,v ,(desugar-exp e))) v* e*))
+	,(desugar-body body))]
+    [`(begin . ,body) (desugar-body body)]
+    [(? atomic?) exp]))
+
+(define (desugar-body body)
+  (match body
+    ['() '()]
+    [(e) (desugar-exp e)]
+    [(e* ...) `(begin ,@(map desugar-exp e*))]))
+
+
+;; CPS conversion
+;; Re-structure the program into "Continuation Passing Style", where non-atomic
+;; expressions must pass their continuations explicitly, changing to a very
+;; "lambda-like" format
+;; - begin expressions are decomposed
+;; - let expressions are transformed into closed function applications
+;; <prgm> ::= <top> ...
+;; <top>  ::= <def> | <exp>
+;; <def>  ::= (define <var> <exp>)
+;; <exp>  ::= <aexp>
+;;          | <cexp>
+;; <cexp> ::= (<aexp> <aexp> ...)
+;;          | (if <aexp> <cexp> <cexp>)
+;;          | (set-then! <var> <aexp> <cexp>)
+;;          | (define-then! <var> <aexp> <cexp>)
+;; <aexp> ::= (lambda (<var> ...) exp)
+;;          | <num> | <var> | #t | #f
+;; 
+;; We choose a hybrid transformation based on https://matt.might.net/articles/cps-conversion/
+
+(define undefined-value (make-symbol "undefined"))
+
+(define (M expr)
+  ;; M dispatches to the appropriate transformer
+  (match expr
+    [('lambda (var ...) e)
+     (let ([$k (gensym "$k")])
+       `(lambda (,@var ,$k) ,(T-c e $k)))]
+    [(? atomic?) expr]))
+
+(define (T-k expr k)
+  ;; T-k takes an explicit continuation and calls it when done
+  ;; As an invariant, T-k cannot nest a T-c call directly
+  (match expr
+    [`(lambda . ,_) (k (M expr))]
+    [ (? atomic?)   (k (M expr))]
+    [ ('define v e) (T-k `(define-then! ,v ,e) k)]
+    [ ('begin e) (T-k e k)]
+    [ ('begin e e* ...)
+      (T-k e (lambda _ (T-k `(begin ,@e*) k)))]
+    [ ('let ([v* e*] ...) body)
+      (T-k `((lambda (,@v*) ,body) ,@e*) k)]
+    [ ('if exp1 exp2 exp3)
+      (T-k exp1 (lambda ($exp1)
+                  `(if ,$exp1
+                       ,(T-k exp2 k)
+                       ,(T-k exp3 k))))]
+    [ ('set! var expr)
+      (T-k expr (lambda ($expr)
+                  `(set-then! ,var ,$expr ,(k undefined-value))))]
+    [((? primitive? f) e* ...)
+     (let* ([$rv (gensym "$rv")]
+            [cont `(lambda (,$rv) ,(k $rv))])
+       (T*-k e* (lambda ($e*)
+                  `((cps ,f) ,@$e* ,cont))))]
+    [(f e* ...)
+     (let* ([$rv (gensym "$rv")]
+	    [cont `(lambda (,$rv) ,(k $rv))])
+       (T-k f (lambda ($f)
+		(T*-k e* (lambda ($e*)
+			   `(,$f ,@$e* ,cont))))))]))
+
+(define (T-c expr c)
+  ;; T-c takes a symbolic continuation, and uses it to construct CPS
+  (match expr
+    [`(lambda . ,_) `(,c ,(M expr))]
+    [ (? atomic?)   `(,c ,(M expr))]
+    [ ('define v e) (T-c `(define-then! ,v ,e) c)]
+    [ ('begin e) (T-c e c)]
+    [ ('begin e e* ...)
+      (T-k e (lambda _ (T-c `(begin ,@e*) c)))]
+    [ ('let ([v* e*] ...) body)
+      (T-c `((lambda (,@v*) ,body) ,@e*) c)]
+    [ ('if exp1 exp2 exp3)
+      (let ([$k (gensym "$k")]) ;; Bind cont to avoid blow up
+        `((lambda (,$k)
+            ,(T-k exp1 (lambda (aexp)
+                         `(if ,aexp
+                              ,(T-c exp2 $k)
+                              ,(T-c exp3 $k)))))
+          ,c))]
+    [ ('set! var expr)
+      (T-k expr (lambda ($expr)
+                  `(set-then! ,var ,$expr (,c ,undefined-value))))]
+    [ ((? primitive? f) e* ...)
+      (T*-k e* (lambda ($e*)
+                 `((cps ,f) ,@$e* ,c)))]
+    [ (f e* ...)
+      (T-k f (lambda ($f)
+	       (T*-k e* (lambda ($e*)
+			  `(,$f ,@$e* ,c)))))]))
+
+(define (cps-convert-prgm prgm)
+  (T-c `(begin ,@prgm) 'ktail))
+
+(define-cps-loop T*-k T-k)
+
+(define (ir-convert prgm)
+  (cps-convert-prgm (desugar-prgm prgm)))
+
+;; Useful for testing
+;; (define (cps prim)
+;;   (lambda vars
+;;     (let* ([rev (reverse vars)]
+;;            [k (car rev)]
+;;            [args (reverse (cdr rev))])
+;;       (k (apply prim args)))))

scmvm/vm.scm

@@ -58,6 +58,9 @@
       [(->list)
        (lambda ()
 	 (reverse-vector->list the-stack 0 top))]
+      [(set!)
+       (lambda (k obj)
+         (vector-set! the-stack k obj))]
       [else (error "stack dispatch unknown value")])))
 
 (define (push stack v)
@@ -81,6 +84,9 @@
 (define (stack->list stack)
   ((stack '->list)))
 
+(define (stack-set! stack k obj)
+  ((stack 'set!) k obj))
+
 
 ;;; IO
 (define (read-word)
@@ -116,6 +122,7 @@
     (rot    #x18)
     (over   #x19)
     (not    #x1a)
+    (set!    #x1b)
     (bye    #xff)))
 
 (define instruction-name car)
@@ -243,6 +250,11 @@
        (push data-stack b)
        (push data-stack a)
        (push data-stack b))]
+    [(set!)
+     ;; use let* to induce an order of evaluation
+     (let* ([idx (pop data-stack)]
+            [obj (pop data-stack)])
+       (stack-set! data-stack idx obj))]
     [(bye) (set! exit? #t)])
   (when (not exit?)
     (run-vm vm)))

tests.scm

@@ -3,7 +3,7 @@
              (scmvm vm)
 	     (scmvm debugger)
 	     (scmvm language assembly)
-	     (scmvm language cps)
+	     (scmvm language scheme)
              (rnrs bytevectors)
              (rnrs io ports)
              ((scheme base)
@@ -167,13 +167,3 @@
     (debugger-continue my-debugger)
     (assert-equal 23 (vm-pc my-vm)) ;; continue stops stepping
     ))
-
-(define-test-suite "cps"
-  (define-test "atomics"
-    (define asm (make-assembler))
-    (compile-cps asm '(1))
-    (assert-equal 1 (bytevector-u32-native-ref (assembler-buf asm) 0)))
-  (define-test "atomics"
-    (define asm (make-assembler))
-    (compile-cps asm '(1))
-    (assert-equal 1 (bytevector-u32-native-ref (assembler-buf asm) 0))))