Cleaner cps interface

asm/runtime.scm

@@ -1,76 +0,0 @@
-;; Note that this is scheme syntax wrapping asm for a stack machine
-(variable scan 0)
-(variable free 0)
-(variable eom 1024)
-;; These need to be initialized later
-(variable root 0)
-(variable the-cars 0) 
-(variable the-cdrs 0)
-(variable new-cars 0)
-(variable new-cdrs 0)
-
-
-(push main)
-(jmp)
-
-alloc
-;; Test if free will go beyond eom
-(push free)
-(@)
-(dup) ; ( -- free free)
-(push 8)
-(+)
-(dup) ; ( -- free free+8 free+8)
-(push eom)
-(@)
-(<) ; ( -- free free+8 (free+8 < eom))
-(branch alloc-do-gc)
-;; write free+8 to free
-(push free)
-(!)
-;; return the old free, it is memory the program can use
-(return)
-alloc-do-gc
-;; Empty the stack
-(drop)
-(drop)
-;; Run garbage collection
-(push gc-start)
-(call)
-;; Tail-call allocation
-(push alloc)
-(jmp)
-
-gc-start
-; Move scan & free back to 0
-(push 0)
-(push free)
-(!)
-(push 0)
-(push scan)
-(!)
-; Push the first cons to relocate (root)
-(push root)
-(@)
-; Call the relocation routine
-(push gc-loop)
-(call)
-; Swap new and old cars and cdrs
-(push new-cars)
-(@)
-(push the-cars)
-(@)
-(push new-cars)
-(!)
-(push the-cars)
-(!)
-(push new-cdrs)
-(@)
-(push the-cdrs)
-(@)
-(push new-cdrs)
-(!)
-(push the-cdrs)
-(!)
-; return to allocation
-(return)

example/asm/runtime.scm

@@ -0,0 +1,153 @@
+(push main)
+(jmp)
+
+;; Note that this is scheme syntax wrapping asm for a stack machine
+(variable eol 0)
+(variable scan 0)
+(variable free 0)
+;; These need to be initialized with the runtime
+(variable eom 0)
+(variable old 0) 
+(variable new 0)
+(variable root 0)
+
+alloc ;; ( -- p)
+;; Test if free will go beyond eom
+(ref free)
+(dup) ; ( -- free free)
+(push 8)
+(+)
+(dup) ; ( -- free free+8 free+8)
+(ref eom)
+(<) ; ( -- free free+8 (free+8 < eom))
+(push alloc-do-gc)
+(if)
+;; write free+8 to free
+(set! free)
+;; return the old free, it is memory the program can use
+(return)
+alloc-do-gc
+;; Empty the stack
+(drop)
+(drop)
+;; Run garbage collection
+(push gc-run)
+(call)
+;; Tail-call allocation
+(push alloc)
+(jmp)
+
+gc-run ;; ( -- )
+; Move scan & free to start of new memory
+(ref new)
+(dup)
+(set! free)
+(set! scan)
+(ref root)
+(push relocate-cons)
+(call)
+(push gc-loop)
+(call)
+; Flip old and new
+(ref old)
+(dup)
+(ref new)
+(set! old)
+(set! new)
+(push 512)
+(+)
+(set! eom)
+(return)
+
+relocate-cons ;; (o -- )
+(dup)
+(@)
+(push relocate-reg)
+(call)
+(push 4)
+(+)
+(@)
+(push relocate-reg)
+
+relocate-reg ;; (r -- )
+(dup)
+(push #x80000000) ;; Is this a cons?
+(and)
+(push reg-relocated)
+(if)
+(dup)
+(ref eol)
+(=) ;; Is this eol?
+(not)
+(push reg-relocated)
+(if)
+(dup)
+(push #x40000000) ;; Is it a broken heart?
+(and)
+(push copy-and-construct)
+(if)
+(dup) ;; Broken heart, copy updated address from cdr
+(push 4)
+(+)
+(@)   ;; Retrieve new address
+(dup)
+(!)   ;; Write it here
+(push reg-relocated)
+(jmp)
+copy-and-construct
+(dup) ;; Wasn't a broken heart, move car to new memory
+(@) 
+(push free)
+(!)
+(dup) ;; Push cdr to new memory
+(push 4)
+(+)
+(@)
+(push free)
+(push 4)
+(+)
+(!)
+(push #x40000000)
+(over)
+(!)
+(ref free)
+(over)
+(push 4)
+(+)
+(!)
+(ref free) ;; Move free pointer
+(push 8)
+(+)
+(set! free)
+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)
+(dup)
+(set! new)
+(push 512)
+(+)
+(dup)
+(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

@@ -0,0 +1,27 @@
+#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

@@ -0,0 +1,64 @@
+// 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_

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,79 +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 (lookup-instruction inst)
-  (define inst-obj (assq inst *instruction-set*))
-  (if inst-obj
-      inst-obj
-      (error (format #f "could not find instruction ~a" inst))))
+(define (make-label) (cons #f '()))
 
-(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-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 (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 (make-assembler*)
+  (make-assembler 0 (make-bytevector 1024) (make-hash-table)))
 
-(define (write-word word)
-  (define bv (make-bytevector 4))
-  (bytevector-s32-native-set! bv 0 word)
-  (write-bytevector bv))
+(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 (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* (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 (assemble instructions port)
-  (define labels (label-pass instructions 1))
-  (with-output-to-port port (lambda () (assembly-pass instructions labels)))
-  labels)
+(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 (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,25 +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)))
+     (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

@@ -3,10 +3,17 @@
                 #:select (read-u8 read-bytevector))
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
-  #:export (make-vm run-vm vm-memory-ref vm-memory-set! vm-memory vm-load-program!
+  #: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))
+		       *instruction-set* instruction-name instruction-code))
 
 ;;; Data Structures
 (define *stack-size* 512)
@@ -48,6 +55,12 @@
       [(ref)
        (lambda (k)
          (vector-ref the-stack k))]
+      [(->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)
@@ -68,6 +81,12 @@
 (define* (make-ram #:optional (memory-size *memory-size*))
   (make-bytevector memory-size #x00))
 
+(define (stack->list stack)
+  ((stack '->list)))
+
+(define (stack-set! stack k obj)
+  ((stack 'set!) k obj))
+
 
 ;;; IO
 (define (read-word)
@@ -102,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)
@@ -117,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)
@@ -126,36 +152,41 @@
     [(=) =]))
 
 
-;;; Execution
-(define* (make-vm #:key stack-size memory-size debugger)
+(define-record-type <vm>
+  (make-vm data-stack ret-stack memory pc debugger)
+  vm?
+  (data-stack vm-data-stack)
+  (ret-stack vm-ret-stack)
+  (memory vm-memory)
+  (pc vm-pc vm-pc-set!)
+  (debugger vm-debugger vm-debugger-set!))
+
+(define* (make-vm* #:key stack-size memory-size debugger)
   "Create a fresh VM, with optional stack and memory sizes"
   (define data-stack (if stack-size (make-stack stack-size) (make-stack)))
   (define ret-stack (if stack-size (make-stack stack-size) (make-stack)))
   (define ram (if memory-size (make-ram memory-size) (make-ram)))
-  (define (ram-word-ref k)
-    (if (< k 1)
-        (error "null memory read")
-        (bytevector-s32-native-ref ram (1- k))))
-  (define (ram-byte-ref k)
-    (if (< k 1)
-        (error "null memory read")
-        (bytevector-u8-ref ram (1- k))))
-  (define (ram-word-set! k v)
-    (if (< k 1)
-        (error "null memory write")
-        (bytevector-s32-native-set! ram (1- k) v)))
-  (define pc 1)
-  (define (jump x) (set! pc x))
+  (make-vm data-stack ret-stack ram 1 debugger))
+
+;;; Execution
+(define (run-vm vm)
+  "Begin execution at pc"
+  (define data-stack (vm-data-stack vm))
+  (define ret-stack (vm-ret-stack vm))
+  (define ram-word-ref (cute vm-memory-ref vm <>))
+  (define ram-byte-ref (cute vm-memory-byte-ref vm <>))
+  (define ram-word-set! (cute vm-memory-set! vm <> <>))
+  (define debugger (vm-debugger vm))
+  (define exit? #f)
+  (define (jump x) (vm-pc-set! vm (logand #x2fffffff x)))
   (define (fetch-byte)
-    (let ([byte (ram-byte-ref pc)])
-      (set! pc (+ pc 1))
+    (let ([byte (ram-byte-ref (vm-pc vm))])
+      (vm-pc-set! vm (+ (vm-pc vm) 1))
       byte))
   (define (fetch-word)
-    (let ([word (ram-word-ref pc)])
-      (set! pc (+ pc 4))
+    (let ([word (ram-word-ref (vm-pc vm))])
+      (vm-pc-set! vm (+ (vm-pc vm) 4))
       word))
-  (define (fetch-and-execute)
-    (define exit? #f)
   (when debugger
     (debugger))
   (define op (fetch-byte))
@@ -188,7 +219,7 @@
          (jump addr)))]
     [(call)
      (let ([addr (pop data-stack)])
-         (push ret-stack pc)
+       (push ret-stack (vm-pc vm))
        (jump addr))]
     [(return)
      (jump (pop ret-stack))]
@@ -219,46 +250,31 @@
        (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?)
-      (fetch-and-execute)))
-  (lambda (x)
-    (case x
-      [(vm-run) fetch-and-execute]
-      [(vm-memory) (lambda () ram)]
-      [(vm-memory-ref) ram-word-ref]
-      [(vm-memory-set!) ram-word-set!]
-      [(vm-pc) (lambda () pc)]
-      [(vm-pc-set!) (lambda (v) (set! pc v))]
-      [else (error "vm unknown dispatch")])))
+    (run-vm vm)))
 
 (define (vm-memory-ref vm k)
-  "Externally access VM memory at k"
-  ((vm 'vm-memory-ref) k))
-
+  (if (< k 1)
+      (error "null memory read")
+      (bytevector-s32-native-ref (vm-memory vm) (1- k))))
+(define (vm-memory-byte-ref vm k)
+  (if (< k 1)
+      (error "null memory read")
+      (bytevector-u8-ref (vm-memory vm) (1- k))))
 (define (vm-memory-set! vm k v)
-  "Externally set VM memory at k to v"
-  ((vm 'vm-memory-set!) k v))
-
-(define (vm-memory vm)
-  "Just get the memory vector"
-  ((vm 'vm-memory)))
+  (if (< k 1)
+      (error "null memory write")
+      (bytevector-s32-native-set! (vm-memory vm) (1- k) v)))
 
 (define (vm-load-program! vm prgm)
   "Loads the bytevector into the vm, starting at memory address 1"
-  (let ([ram ((vm 'vm-memory))])
+  (let ([ram (vm-memory vm)])
     (bytevector-copy! prgm 0
                       ram 0
                       (bytevector-length prgm))))
-
-(define (vm-pc vm)
-  "Return the value of the pc"
-  ((vm 'vm-pc)))
-
-(define (vm-pc-set! vm pc)
-  "Set the value of the pc"
-  ((vm 'vm-pc-set!) pc))
-
-(define (run-vm vm)
-  "Begin execution at pc"
-  ((vm 'vm-run))) 

tests.scm

@@ -1,13 +1,16 @@
 (use-modules (d- test)
 	     (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)
@@ -16,7 +19,7 @@
     (!)
     (bye)))
 
-(define fib-program-asm
+(define fib-program-assembly
   '(  (variable result 0)
       (ref result)
       (push fib)
@@ -32,7 +35,7 @@
       (=)
       (or)
       (push recur)
-      (branch)
+      (if)
       (return)
     recur
       (dup)
@@ -102,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"
@@ -120,12 +122,48 @@
     (define my-vm (make-vm))
     (vm-load-program! my-vm adder-program-bytecode)
     (vm-pc-set! my-vm 5)
-    ((my-vm 'vm-run))
+    (run-vm my-vm)
     (assert-equal 3 (vm-memory-ref my-vm 1)))
   (define-test "fib"
     (define my-vm (make-vm))
     (vm-load-program! my-vm fib-program-bytecode)
     (vm-memory-set! my-vm 1 10)
     (vm-pc-set! my-vm 5)
-    ((my-vm 'vm-run))
+    (run-vm my-vm)
     (assert-equal 55 (vm-memory-ref my-vm 1))))
+
+(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))
+    (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 10 (stack-peek my-data))
+    (stack-pop my-data)
+    (stack-push my-data 1)
+    (debugger-continue my-debugger)
+    (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
+    ))