Cps conversion for full programs?

scmvm/assembler.scm

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

scmvm/language/common.scm

@@ -1,67 +0,0 @@
-(define-module (scmvm language common)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-9)
-  #:use-module (rnrs bytevectors)
-  #:export (<assembler>
-	    (make-assembler* . make-assembler)
-	    assembler?
-	    assembler-labels
-	    assembler-pos
-	    assembler-buf
-	    assembler-pos-set!
-	    assembler-buf-set!
-	    assembler-label-add-reference
-	    assembler-label-add-value
-	    write-byte
-	    write-word
-	    emit-label
-	    finalize-references))
-
-(define (make-label) (cons #f '()))
-
-(define-record-type <assembler>
-  (make-assembler pos buf labels)
-  assembler?
-  (pos assembler-pos assembler-pos-set!)
-  (buf assembler-buf assembler-buf-set!)
-  (labels assembler-labels))
-
-(define (make-assembler*)
-  (make-assembler 0 (make-bytevector 1024) (make-hash-table)))
-
-(define (assembler-buf-grow! asm)
-  (let ([buf (make-bytevector (ash (bytevector-length (assembler-buf asm)) -1))])
-    (bytevector-copy! (assembler-buf asm) 0 buf 0 (bytevector-length (assembler-buf asm)))
-    (assembler-buf-set! asm buf)))
-
-(define* (write-word word asm #:optional (pos (assembler-pos asm)))
-  (when (> (+ pos 4) (bytevector-length (assembler-buf asm)))
-    (assembler-buf-grow! asm))
-  (bytevector-u32-native-set! (assembler-buf asm) pos word))
-
-(define* (write-byte byte asm #:optional (pos (assembler-pos asm)))
-  (when (> (+ pos 1) (bytevector-length (assembler-buf asm)))
-    (assembler-buf-grow! asm))
-  (bytevector-u8-set! (assembler-buf asm) pos byte))
-
-(define (assembler-label-add-reference asm name addr)
-  (when (not (hash-ref (assembler-labels asm) name))
-    (hash-set! (assembler-labels asm) name (make-label)))
-  (let ([label (hash-ref (assembler-labels asm) name)])
-    (set-cdr! label (cons addr (cdr label)))))
-
-(define (assembler-label-add-value asm name val)
-  (when (not (hash-ref (assembler-labels asm) name))
-    (hash-set! (assembler-labels asm) name (make-label)))
-  ;; 1+ to fudge for null pointers
-  (set-car! (hash-ref (assembler-labels asm) name) (1+ val)))
-
-(define (finalize-references asm)
-  (define (install-location _name label)
-    (for-each
-     (cute write-word (car label) asm <>)
-     (cdr label)))
-  (hash-for-each install-location (assembler-labels asm)))
-
-(define (emit-label asm name)
-  (assembler-label-add-value asm name (assembler-pos asm)))

scmvm/language/scheme.scm

@@ -0,0 +1,181 @@
+(define-module (scmvm language scheme)
+  #:use-module (scmvm assembler)
+  #:use-module (ice-9 match))
+
+;; 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-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 (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>)
+;; <aexp> ::= (lambda (<var> ...) exp)
+;;          | <num> | <sym> | <var> | #t | #f
+;; 
+;; We choose a hybrid transformation based on https://matt.might.net/articles/cps-conversion/
+
+(define undefined-value (make-symbol "undefined"))
+
+(define (cps-convert expr ktail)
+  ;; M : expr -> aexp
+  ;; T-k : expr, (aexp -> cexp) -> cexp
+  ;; T-c : expr, aexp -> cexp
+  (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))]
+      [ ('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))))]
+      [(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))]
+      [ ('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))))]
+      [ (f e* ...)
+        (T-k f (lambda ($f)
+		 (T*-k e* (lambda ($e*)
+			    `(,$f ,@$e* ,c)))))]))
+  (define-cps-loop T*-k T-k)
+  (T-k expr ktail))
+
+(define (cps-convert-prgm prgm)
+  (if (pair? prgm)
+      (cons (cps-convert-top (car prgm))
+            (cps-convert-prgm (cdr prgm)))
+      '()))
+
+(define (cps-convert-top top)
+  (match top
+    [`(define ,v ,e)
+     (cps-convert e (lambda ($rv) `(define ,v ,$rv)))]
+    [_
+     (cps-convert top (lambda _ `(nop)))]))

tests.scm

@@ -1,8 +1,9 @@
 (use-modules (d- test)
 	     (scmvm assembler)
-             (scmvm language assembly)
              (scmvm vm)
 	     (scmvm debugger)
+	     (scmvm language assembly)
+	     (scmvm language scheme)
              (rnrs bytevectors)
              (rnrs io ports)
              ((scheme base)