Cleaner cps interface

example/asm/runtime.scm

@@ -1,3 +1,6 @@
+(push main)
+(jmp)
+
 ;; Note that this is scheme syntax wrapping asm for a stack machine
 (variable eol 0)
 (variable scan 0)
@@ -8,9 +11,6 @@
 (variable new 0)
 (variable root 0)
 
-(push main)
-(jmp)
-
 alloc ;; ( -- p)
 ;; Test if free will go beyond eom
 (ref free)
@@ -31,7 +31,7 @@ alloc-do-gc
 (drop)
 (drop)
 ;; Run garbage collection
-(push gc-start)
+(push gc-run)
 (call)
 ;; Tail-call allocation
 (push alloc)
@@ -123,6 +123,19 @@ reg-relocated
 (drop)
 (return)
 
+gc-loop
+(ref free)
+(ref scan)
+(<)
+(branch gc-loop-done)
+(ref scan)
+(push relocate-reg)
+(push gc-loop)
+(jmp)
+gc-loop-done
+(return)
+
+
 main
 ;; These need to be initialized with the runtime
 (push memory)
@@ -134,5 +147,7 @@ main
 (set! eom)
 (set! old)
 ;; TODO set up root
+;; <<USER PROGRAM HERE >>
+(bye)
 
 memory

example/c/.gitignore

@@ -0,0 +1,3 @@
+*.o
+scheme
+scheme.exe

example/c/Makefile

@@ -0,0 +1,5 @@
+CFLAGS=-g
+
+all: scheme
+
+scheme: gc.o runtime.o

example/c/common.h

@@ -1,28 +1,27 @@
-#include <stdint.h>
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-
-#define SIZE 8
-#define BROKEN_HEART 1
-#define CONS 2
-#define INTEGER 3
-
-typedef struct box_t {
-  char type;
-  union {
-    int integer;
-    struct cons_t* cons;
-  };
-} box_t;
-
-typedef struct cons_t {
-  box_t car;
-  box_t cdr;
-} cons_t;
-
-void init();
-cons_t *alloc();
-void gc_run();
-void gc_loop();
-void relocate(cons_t*);
+#ifndef _COMMON_H_
+#define _COMMON_H_
+
+#define SIZE 1024
+#define BROKEN_HEART 1
+#define CONS 2
+#define INTEGER 3
+#define SYMBOL 4
+#define BYE 5
+
+typedef struct box_t {
+  char type;
+  union {
+    int integer;
+    char* symbol;
+    struct cons_t* cons;
+  };
+} box_t;
+
+typedef struct cons_t {
+  box_t car;
+  box_t cdr;
+} cons_t;
+
+extern cons_t *the_empty_list;
+
+#endif // _COMMON_H_

example/c/gc.c

@@ -1,88 +1,64 @@
-// Cheney style stop and copy garbage collector
-#include "gc.h"
-
-static cons_t *old, *new, *scanptr, *freeptr, *eom, *root;
-static cons_t *the_empty_list = NULL;
-size_t tos;
-
-void init() {
-  old = calloc(sizeof(cons_t), SIZE);
-  freeptr = old;
-  eom = old + (SIZE / 2);
-  new = eom + 1;
-  root = alloc();
-}
-
-cons_t *alloc() {
-  if (freeptr < eom) {
-    cons_t *retval = freeptr;
-    freeptr++;
-    return retval;
-  } else {
-    gc_run();
-    return alloc();
-  }
-}
-
-void gc_run() {
-  freeptr = new;
-  scanptr = new;
-  // Relocate root
-  relocate(root);
-  // Enter the main GC loop
-  gc_loop();
-  // Flip old and new;
-  cons_t *temp = old;
-  old = new;
-  new = temp;
-}
-
-void gc_loop() {
-  while (scanptr < freeptr) {
-    relocate(scanptr);
-    scanptr++;
-  }
-}
-
-void move(box_t box) {
-  if (box.type == CONS && box.cons != the_empty_list) {
-    if (box.cons->car.type == BROKEN_HEART) {
-      box.cons = box.cons->cdr.cons;
-    } else {
-      memcpy(freeptr, box.cons, sizeof(cons_t));
-      box.cons->car.type = BROKEN_HEART;
-      box.cons->cdr.cons = freeptr;
-      freeptr++;
-    }
-  }
-}
-
-void relocate(cons_t* cons) {
-  move(cons->car);
-  move(cons->cdr);
-}
-
-int main() {
-  init();
-  // Simulate running linear fibonnaci
-  root->car.type = INTEGER;
-  root->car.integer = 1;
-  root->cdr.type = CONS;
-  root->cdr.cons = alloc();
-  root->cdr.cons->car.type = INTEGER;
-  root->cdr.cons->car.integer = 0;
-  root->cdr.cons->cdr.type = CONS;
-  root->cdr.cons->cdr.cons = the_empty_list;
-  for (size_t i = 0; i < 29; i++) {
-    cons_t *cons = alloc();
-    cons->car.type = INTEGER;
-    cons->car.integer = root->car.integer + root->cdr.cons->car.integer;
-    
-    cons->cdr.type = CONS;
-    cons->cdr.cons = root;
-    root->cdr.cons = the_empty_list;
-    root = cons;
-  };
-  printf("%d\n", root->car.integer); // 832040, and we've definitely run gc a few times
-}
-
+// Cheney style stop and copy garbage collector
+#include "gc.h"
+
+cons_t *the_empty_list = NULL;
+
+static cons_t *old, *new, *scanptr, *freeptr, *eom, *root;
+size_t tos;
+
+void gc_init() {
+  old = calloc(sizeof(cons_t), SIZE);
+  freeptr = old;
+  eom = old + (SIZE / 2);
+  new = eom + 1;
+  root = alloc();
+}
+
+cons_t *alloc() {
+  if (freeptr < eom) {
+    cons_t *retval = freeptr;
+    freeptr++;
+    return retval;
+  } else {
+    gc_run();
+    return alloc();
+  }
+}
+
+void gc_run() {
+  freeptr = new;
+  scanptr = new;
+  // Relocate root
+  relocate(root);
+  // Enter the main GC loop
+  gc_loop();
+  // Flip old and new;
+  cons_t *temp = old;
+  old = new;
+  new = temp;
+}
+
+void gc_loop() {
+  while (scanptr < freeptr) {
+    relocate(scanptr);
+    scanptr++;
+  }
+}
+
+void move(box_t box) {
+  if (box.type == CONS && box.cons != the_empty_list) {
+    if (box.cons->car.type == BROKEN_HEART) {
+      box.cons = box.cons->cdr.cons;
+    } else {
+      memcpy(freeptr, box.cons, sizeof(cons_t));
+      box.cons->car.type = BROKEN_HEART;
+      box.cons->cdr.cons = freeptr;
+      freeptr++;
+    }
+  }
+}
+
+void relocate(cons_t* cons) {
+  move(cons->car);
+  move(cons->cdr);
+}

example/c/gc.h

@@ -0,0 +1,16 @@
+#ifndef _GC_H_
+#define _GC_H_
+
+#include <stdint.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include "common.h"
+
+void gc_init();
+cons_t *alloc();
+void gc_run();
+void gc_loop();
+void relocate(cons_t*);
+
+#endif // _GC_H_

reference/Makefile

@@ -1,6 +0,0 @@
-CFLAGS=-g
-
-all: gctest
-
-gctest: gc.o
-	$(CC) $(CFLAGS) -o $@ $<

scmvm.scm

@@ -1,21 +1,7 @@
 (define-module (scmvm)
-  #:use-module (scmvm vm)
-  #:use-module (scmvm assembler)
-  #:use-module (scmvm debugger)
   #:use-module (ice-9 ports)
-  #:re-export ( ;; vm
-               make-vm run-vm vm-load-program!
-               vm-memory-ref vm-memory-set!
-               vm-pc vm-pc-set!
-               ;; assembler
-               assemble
-               ;; debugger
-               make-debugger debugger-continue
-               debugger-vm
-               debugger-breakpoints debugger-breakpoints-set!
-               debugger-breakpoint-add! debugger-breakpoint-ref
-               debugger-breakpoint-enable! debugger-breakpoint-disable!)
-  #:export (read-all-instructions instructions-from-file))
+  #:export (read-all-instructions
+	    instructions-from-file))
 
 (define (read-all-instructions)
   (let ([inst (read)])

scmvm/assembler.scm

@@ -1,85 +1,82 @@
 (define-module (scmvm assembler)
-  #:use-module (srfi srfi-1)
   #:use-module (scmvm vm)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-9)
   #:use-module (rnrs bytevectors)
-  #:use-module (rnrs io ports)
-  #:use-module ((scheme base)
-                #:select (write-u8 write-bytevector))
-  #:export (assemble))
+  #:use-module ((scheme base) #:select (write-bytevector))
+  #:export ((make-assembler* . make-assembler)
+	    assembler?
+	    assembler-pos assembler-pos-set!
+	    assembler-buf
+	    assembler-labels
+	    emit-label
+	    emit-instruction
+	    emit-literal
+	    emit-reference
+	    finalize-references
+	    assembler-dump-program))
 
-(define *aliases*
-  '((if . branch)))
+(define (make-label) (cons #f '()))
 
-(define (or-alias inst)
-  (or (assq-ref *aliases* inst) inst))
+(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 (lookup-instruction inst)
-  (define inst-obj (assq (or-alias inst) *instruction-set*))
-  (if inst-obj
-      inst-obj
-      (error (format #f "could not find instruction ~a" inst))))
+(define (make-assembler*)
+  (make-assembler 0 (make-bytevector 1024) (make-hash-table)))
 
-(define label? (compose not pair?))
-(define (variable? x)
-  (and (pair? x) (eq? (car x) 'variable)))
-(define (ref? x)
-  (and (pair? x) (eq? (car x) 'ref)))
-(define (set!? x)
-  (and (pair? x) (eq? (car x) 'set!)))
-(define (instruction? x)
-  (and (not (label? x))
-       (not (variable? x))
-       (not (ref? x))
-       (not (set!? x))))
-(define (instruction-size inst)
-  (case (car inst)
-    [(push) 5]
-    [(ref set!) 6]
-    [else 1]))
+(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 (label-pass instructions address)
-  (cond
-   [(null? instructions) '()]
-   [(label? (car instructions))
-    (acons (car instructions) address (label-pass (cdr instructions) address))]
-   [(variable? (car instructions))
-    (acons (cadar instructions) address (label-pass (cdr instructions) (+ address 4)))]
-   [else
-    (label-pass (cdr instructions) (+ address (instruction-size (car instructions))))]))
+(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-word word)
-  (define bv (make-bytevector 4))
-  (bytevector-s32-native-set! bv 0 word)
-  (write-bytevector bv))
+(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 (assembly-pass seq labels)
-  (cond
-   [(null? seq) '()]
-   [(label? (car seq)) (assembly-pass (cdr seq) labels)]
-   [(variable? (car seq))
-    (write-word (caddar seq))
-    (assembly-pass (cdr seq) labels)]
-   [(ref? (car seq))
-    (write-u8 (cadr (lookup-instruction 'push)))
-    (write-word (assq-ref labels (cadar seq)))
-    (write-u8 (cadr (lookup-instruction '@)))
-    (assembly-pass (cdr seq) labels)]
-   [(set!? (car seq))
-    (write-u8 (cadr (lookup-instruction 'push)))
-    (write-word (assq-ref labels (cadar seq)))
-    (write-u8 (cadr (lookup-instruction '!)))
-    (assembly-pass (cdr seq) labels)]
-   [else
-    (let* ([inst (car seq)]
-           [inst-obj (lookup-instruction (car inst))])
-      (write-u8 (instruction-code inst-obj))
-      (when (eq? (car inst) 'push)
-        (if (number? (cadr inst))
-            (write-word (cadr inst))
-            (write-word (assq-ref labels (cadr inst)))))
-      (assembly-pass (cdr seq) labels))]))
+(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 (assemble instructions port)
-  (define labels (label-pass instructions 1))
-  (with-output-to-port port (lambda () (assembly-pass instructions labels)))
-  labels)
+(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 (emit-label asm name)
+  (assembler-label-add-value asm name (assembler-pos asm)))
+
+(define (emit-instruction asm inst)
+  (let ([inst-object (assq inst *instruction-set*)])
+    (write-byte (instruction-code inst-object) asm)
+    (assembler-pos-set! asm (+ (assembler-pos asm) 1))))
+
+(define (emit-literal asm val)
+  (write-word val asm)
+  (assembler-pos-set! asm (+ (assembler-pos asm) 4)))
+
+(define (emit-reference asm name)
+  (assembler-label-add-reference asm name (assembler-pos asm))
+  (assembler-pos-set! asm (+ (assembler-pos asm) 4)))
+
+(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 (assembler-dump-program asm port)
+  (write-bytevector (assembler-buf asm) port 0 (assembler-pos asm)))

scmvm/debugger.scm

@@ -12,22 +12,23 @@
             debugger-breakpoint-add! debugger-breakpoint-ref
             debugger-breakpoint-enable! debugger-breakpoint-disable!
             debugger-breakpoint-delete!
-            debugger-continue))
+            debugger-step debugger-continue))
 
 (define-record-type <debugger>
-  (make-debugger vm source breakpoints continuation)
+  (make-debugger vm asm breakpoints continuation stepping)
   debugger?
   (vm debugger-vm)
-  (source debugger-source)
+  (asm debugger-asm)
   (breakpoints debugger-breakpoints)
-  (continuation debugger-continuation debugger-continuation-set!))
+  (continuation debugger-continuation debugger-continuation-set!)
+  (stepping debugger-stepping? debugger-stepping-set!))
 
-(define (make-breakpoints labels)
+(define (make-breakpoints asm)
   (define the-breakpoints '())
   (define (->index index/label)
     (if (number? index/label)
         index/label
-        (assq-ref labels index/label)))
+        (car (hash-ref (assembler-labels asm) index/label))))
   (define-syntax-rule (ilambda (i) e ...)
     (lambda (v) (let ([i (->index v)]) e ...)))
   (match-lambda
@@ -42,26 +43,32 @@
     ['ref
      (ilambda (i) (assq-ref the-breakpoints i))]))
 
-(define (make-debugger* source)
-  (define-values (prgm symbols)
+(define (make-debugger* asm)
+  (define prgm
     (call-with-values open-bytevector-output-port
       (lambda (port get-bv)
-        (define symbols (assemble source port))
-        (values (get-bv) symbols))))
+	(assembler-dump-program asm port)
+	(get-bv))))
   (define the-debugger #f)
   (define (debug)
     (shift k
-      (if (((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger)))
-          (debugger-continuation-set! the-debugger k)
-          (k))))
+     (if (or (debugger-stepping? the-debugger)
+             (((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger))))
+         (debugger-continuation-set! the-debugger k)
+         (k))))
   (define vm (make-vm #:debugger debug))
   (vm-load-program! vm prgm)
-  (set! the-debugger (make-debugger vm source (make-breakpoints symbols) #f))
+  (set! the-debugger (make-debugger vm asm (make-breakpoints asm) #f #f))
   (debugger-breakpoint-add! the-debugger 1)
   (reset (run-vm vm))
   the-debugger)
 
 (define (debugger-continue debugger)
+  (debugger-stepping-set! debugger #f)
+  ((debugger-continuation debugger)))
+
+(define (debugger-step debugger)
+  (debugger-stepping-set! debugger #t)
   ((debugger-continuation debugger)))
 
 (define (debugger-breakpoint-add! debugger breakpoint)

scmvm/language/assembly.scm

@@ -0,0 +1,59 @@
+(define-module (scmvm language assembly)
+  #:use-module (scmvm vm)
+  #:use-module (scmvm assembler)
+  #:use-module (srfi srfi-1)
+  #:use-module ((scheme base) #:select (write-bytevector))
+  #:export (assemble assemble-instructions))
+
+(define *aliases*
+  '((if . branch)))
+
+(define (or-alias inst)
+  (or (assq-ref *aliases* inst) inst))
+
+(define (lookup-instruction inst)
+  (define inst-obj (assq (or-alias inst) *instruction-set*))
+  (or inst-obj
+      (error (format #f "could not find instruction ~a" inst))))
+
+(define label? (negate pair?))
+(define (variable? x)
+  (and (pair? x) (eq? (car x) 'variable)))
+(define (ref? x)
+  (and (pair? x) (eq? (car x) 'ref)))
+(define (set!? x)
+  (and (pair? x) (eq? (car x) 'set!)))
+(define (push? x)
+  (and (pair? x) (eq? (car x) 'push)))
+
+(define (emit-push asm v)
+  (emit-instruction asm 'push)
+  (if (number? v)
+      (emit-literal asm v)
+      (emit-reference asm v)))
+
+(define (assemble-instructions asm inst-seq)
+  (when (pair? inst-seq)
+    (cond
+     [(label? (car inst-seq))
+      (emit-label asm (car inst-seq))]
+     [(variable? (car inst-seq))
+      (emit-label asm (second (car inst-seq)))
+      (emit-literal asm (third (car inst-seq)))]
+     [(ref? (car inst-seq))
+      (emit-push asm (second (car inst-seq)))
+      (emit-instruction asm '@)]
+     [(set!? (car inst-seq))
+      (emit-push asm (second (car inst-seq)))
+      (emit-instruction asm '!)]
+     [(push? (car inst-seq))
+      (emit-push asm (second (car inst-seq)))]
+     [else
+      (emit-instruction asm (instruction-name (lookup-instruction (first (car inst-seq)))))])
+    (assemble-instructions asm (cdr inst-seq))))
+
+(define (assemble instructions port)
+  (define asm (make-assembler))
+  (assemble-instructions asm instructions)
+  (finalize-references asm)
+  (assembler-dump-program asm port))

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

@@ -6,13 +6,14 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-43)
+  #:use-module (ice-9 format)
   #:export (make-stack (push . stack-push) (pop . stack-pop) (peek . stack-peek) stack-ref stack->list
-	    (make-vm* . make-vm) run-vm
-    	    vm-memory-ref vm-memory-byte-ref vm-memory-set! vm-memory vm-load-program!
-	    vm-data-stack vm-ret-stack
-	    vm-debugger vm-debugger-set!
-            vm-pc vm-pc-set!
-            *instruction-set* instruction-type instruction-code))
+		       (make-vm* . make-vm) run-vm
+    		       vm-memory-ref vm-memory-byte-ref vm-memory-set! vm-memory vm-load-program!
+		       vm-data-stack vm-ret-stack
+		       vm-debugger vm-debugger-set!
+		       vm-pc vm-pc-set!
+		       *instruction-set* instruction-name instruction-code))
 
 ;;; Data Structures
 (define *stack-size* 512)
@@ -57,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)
@@ -80,6 +84,9 @@
 (define (stack->list stack)
   ((stack '->list)))
 
+(define (stack-set! stack k obj)
+  ((stack 'set!) k obj))
+
 
 ;;; IO
 (define (read-word)
@@ -114,12 +121,18 @@
     (swap   #x17)
     (rot    #x18)
     (over   #x19)
+    (not    #x1a)
+    (set!    #x1b)
     (bye    #xff)))
 
+(define instruction-name car)
 (define instruction-code cadr)
 
 (define (op-lookup code)
-  (car (find (lambda (x) (= (instruction-code x) code)) *instruction-set*)))
+  (let ([op (find (lambda (x) (= (instruction-code x) code)) *instruction-set*)])
+    (if op
+	(car op)
+	(error (format #f "tried to execute non-existant instruction ~x" code)))))
 
 (define (binop-lookup op)
   (case (op-lookup op)
@@ -129,7 +142,8 @@
     [(or) logior]
     [(nand) (compose lognot logand)]
     [(nor) (compose lognot logior)]
-    [(xor) logxor]))
+    [(xor) logxor]
+    [(not) lognot]))
 
 (define (relop-lookup op)
   (case (op-lookup op)
@@ -236,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

@@ -1,14 +1,16 @@
 (use-modules (d- test)
-             (scmvm assembler)
+	     (scmvm assembler)
              (scmvm vm)
 	     (scmvm debugger)
+	     (scmvm language assembly)
+	     (scmvm language scheme)
              (rnrs bytevectors)
              (rnrs io ports)
              ((scheme base)
               #:select (open-output-bytevector get-output-bytevector)))
 
 ;;; Data
-(define adder-program-asm
+(define adder-program-assembly
   '((variable result 0)
     (push 1)
     (push 2)
@@ -17,7 +19,7 @@
     (!)
     (bye)))
 
-(define fib-program-asm
+(define fib-program-assembly
   '(  (variable result 0)
       (ref result)
       (push fib)
@@ -103,17 +105,16 @@
        #x02          ; Store fib(n)
        #xff          ; Exit program
        ))
-
 
 ;;; Tests
-(define-test-suite "assembler"
+(define-test-suite "assembly"
   (define-test "adder"
     (define out (open-output-bytevector))
-    (assemble adder-program-asm out)
+    (assemble adder-program-assembly out)
     (assert-equal adder-program-bytecode (get-output-bytevector out)))
   (define-test "fib"
     (define out (open-output-bytevector))
-    (assemble fib-program-asm out)
+    (assemble fib-program-assembly out)
     (assert-equal fib-program-bytecode (get-output-bytevector out))))
 
 (define-test-suite "vm"
@@ -133,6 +134,9 @@
 
 (define-test-suite "debugger"
   (define-test "modify-running-program"
+    (define fib-program-asm (make-assembler))
+    (assemble-instructions fib-program-asm fib-program-assembly)
+    (finalize-references fib-program-asm)
     (define my-debugger (make-debugger fib-program-asm))
     (define my-vm (debugger-vm my-debugger))
     (define my-data (vm-data-stack my-vm))
@@ -144,4 +148,22 @@
     (stack-pop my-data)
     (stack-push my-data 1)
     (debugger-continue my-debugger)
-    (assert-equal 1 (vm-memory-ref my-vm 1))))
+    (assert-equal 1 (vm-memory-ref my-vm 1)))
+  (define-test "stepping"
+    (define fib-program-asm (make-assembler))
+    (assemble-instructions fib-program-asm fib-program-assembly)
+    (finalize-references fib-program-asm)
+    (define my-debugger (make-debugger fib-program-asm))
+    (define my-vm (debugger-vm my-debugger))
+    (vm-memory-set! my-vm 1 10)
+    (vm-pc-set! my-vm 5)
+    (debugger-breakpoint-add! my-debugger 'fib)
+    (debugger-continue my-debugger)
+    (assert-equal 23 (vm-pc my-vm))
+    (debugger-step my-debugger)
+    (assert-equal 24 (vm-pc my-vm)) ;; dup is a 1 byte instruction
+    (debugger-step my-debugger)
+    (assert-equal 29 (vm-pc my-vm)) ;; push is a 5 byte instruction
+    (debugger-continue my-debugger)
+    (assert-equal 23 (vm-pc my-vm)) ;; continue stops stepping
+    ))