Delete old vm

scmvm/assembler.scm

@@ -9,24 +9,26 @@
 	    assembler-pos assembler-pos-set!
 	    assembler-buf
 	    assembler-labels
+            assembler-instruction-set
 	    emit-label
 	    emit-instruction
 	    emit-literal
 	    emit-reference
-	    finalize-references
+            assembler-backpatch!
 	    assembler-dump-program))
 
 (define (make-label) (cons #f '()))
 
 (define-record-type <assembler>
-  (make-assembler pos buf labels)
+  (make-assembler pos buf labels instruction-set)
   assembler?
   (pos assembler-pos assembler-pos-set!)
   (buf assembler-buf assembler-buf-set!)
-  (labels assembler-labels))
+  (labels assembler-labels)
+  (instruction-set assembler-instruction-set))
 
-(define (make-assembler*)
+(define (make-assembler* instruction-set)
-  (make-assembler 0 (make-bytevector 1024) (make-hash-table)))
+  (make-assembler 0 (make-bytevector 1024) (make-hash-table) instruction-set))
 
 (define (assembler-buf-grow! asm)
   (let ([buf (make-bytevector (ash (bytevector-length (assembler-buf asm)) -1))])
@@ -59,7 +61,7 @@
   (assembler-label-add-value asm name (assembler-pos asm)))
 
 (define (emit-instruction asm inst)
-  (let ([inst-object (assq inst *instruction-set*)])
+  (let ([inst-object (instruction-lookup (assembler-instruction-set asm) inst)])
     (write-byte (instruction-code inst-object) asm)
     (assembler-pos-set! asm (+ (assembler-pos asm) 1))))
 
@@ -71,7 +73,7 @@
   (assembler-label-add-reference asm name (assembler-pos asm))
   (assembler-pos-set! asm (+ (assembler-pos asm) 4)))
 
-(define (finalize-references asm)
+(define (assembler-backpatch! asm)
   (define (install-location _name label)
     (for-each
      (cute write-word (car label) asm <>)

scmvm/debugger.scm

@@ -1,13 +1,14 @@
 (define-module (scmvm debugger)
   #:use-module (scmvm assembler)
   #:use-module (scmvm vm)
+  #:use-module (scmvm vm forth)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 control)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 match)
-  #:export ((make-debugger* . make-debugger) debugger-vm debugger-source
+  #:export (make-forth-debugger debugger-vm debugger-source
             debugger-breakpoints debugger-breakpoints-set!
             debugger-breakpoint-add! debugger-breakpoint-ref
             debugger-breakpoint-enable! debugger-breakpoint-disable!
@@ -23,27 +24,21 @@
   (continuation debugger-continuation debugger-continuation-set!)
   (stepping debugger-stepping? debugger-stepping-set!))
 
-(define (make-breakpoints asm)
+(define* (make-breakpoints #:optional (convert identity))
-  (define the-breakpoints '())
+  (define the-breakpoints (make-hash-table))
-  (define (->index index/label)
+  (match-lambda
+    [(or 'add 'enable) (lambda (key) (hashq-set! the-breakpoints (convert key) #t))]
+    ['disable (lambda (key) (hashq-set! the-breakpoints (convert key) #f))]
+    ['delete (lambda (key) (hashq-remove! the-breakpoints (convert key)))]
+    ['ref (lambda (key) (hashq-ref the-breakpoints (convert key) #f))]))
+
+(define (label-converter asm)
+  (lambda (index/label)
     (if (number? index/label)
         index/label
-        (car (hash-ref (assembler-labels asm) 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
-    ['add
-     (ilambda (i) (set! the-breakpoints (acons i #t the-breakpoints)))]
-    ['delete
-     (ilambda (i) (set! the-breakpoints (assq-remove! the-breakpoints i)))]
-    ['enable
-     (ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #t)))]
-    ['disable
-     (ilambda (i) (set! the-breakpoints (assq-set! the-breakpoints i #f)))]
-    ['ref
-     (ilambda (i) (assq-ref the-breakpoints i))]))
 
-(define (make-debugger* asm)
+(define (make-forth-debugger asm)
   (define prgm
     (call-with-values open-bytevector-output-port
       (lambda (port get-bv)
@@ -53,14 +48,14 @@
   (define (debug)
     (shift k
            (if (or (debugger-stepping? the-debugger)
-             (((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger))))
+                   (((debugger-breakpoints the-debugger) 'ref) (forth-vm-pc (debugger-vm the-debugger))))
                (debugger-continuation-set! the-debugger k)
                (k))))
-  (define vm (make-vm #:debugger debug))
+  (define vm (make-forth-vm (assembler-instruction-set asm)))
-  (vm-load-program! vm prgm)
+  (forth-vm-load-program! vm prgm)
-  (set! the-debugger (make-debugger vm asm (make-breakpoints asm) #f #f))
+  (set! the-debugger (make-debugger vm asm (make-breakpoints (label-converter asm)) #f #f))
   (debugger-breakpoint-add! the-debugger 1)
-  (reset (run-vm vm))
+  (reset (forth-vm-run! vm debug))
   the-debugger)
 
 (define (debugger-continue debugger)

scmvm/language/assembly.scm

@@ -3,7 +3,7 @@
   #:use-module (scmvm assembler)
   #:use-module (srfi srfi-1)
   #:use-module ((scheme base) #:select (write-bytevector))
-  #:export (assemble assemble-instructions))
+  #:export (assemble assemble-instructions!))
 
 (define *aliases*
   '((if . branch)))
@@ -11,10 +11,10 @@
 (define (or-alias inst)
   (or (assq-ref *aliases* inst) inst))
 
-(define (lookup-instruction inst)
+(define (lookup-instruction isa inst)
-  (define inst-obj (assq (or-alias inst) *instruction-set*))
+  (define inst-obj (instruction-lookup isa (or-alias inst)))
   (or inst-obj
-      (error (format #f "could not find instruction ~a" inst))))
+      (error (format #f "could not find instruction ~a in ISA ~a" inst isa))))
 
 (define label? (negate pair?))
 (define (variable? x)
@@ -32,28 +32,29 @@
       (emit-literal asm v)
       (emit-reference asm v)))
 
-(define (assemble-instructions asm inst-seq)
+(define (assemble-instructions! asm inst-seq)
   (when (pair? inst-seq)
+    (define next-inst (car inst-seq))
     (cond
-     [(label? (car inst-seq))
+     [(label? next-inst)
-      (emit-label asm (car inst-seq))]
+      (emit-label asm next-inst)]
-     [(variable? (car inst-seq))
+     [(variable? next-inst)
-      (emit-label asm (second (car inst-seq)))
+      (emit-label asm (second next-inst))
-      (emit-literal asm (third (car inst-seq)))]
+      (emit-literal asm (third next-inst))]
-     [(ref? (car inst-seq))
+     [(ref? next-inst)
-      (emit-push asm (second (car inst-seq)))
+      (emit-push asm (second next-inst))
       (emit-instruction asm '@)]
-     [(set!? (car inst-seq))
+     [(set!? next-inst)
-      (emit-push asm (second (car inst-seq)))
+      (emit-push asm (second next-inst))
       (emit-instruction asm '!)]
-     [(push? (car inst-seq))
+     [(push? next-inst)
-      (emit-push asm (second (car inst-seq)))]
+      (emit-push asm (second next-inst))]
      [else
-      (emit-instruction asm (instruction-name (lookup-instruction (first (car inst-seq)))))])
+      (emit-instruction asm (instruction-name (lookup-instruction (assembler-instruction-set asm) (first next-inst))))])
-    (assemble-instructions asm (cdr inst-seq))))
+    (assemble-instructions! asm (cdr inst-seq))))
 
-(define (assemble instructions port)
+(define (assemble instructions instruction-set port)
-  (define asm (make-assembler))
+  (define asm (make-assembler instruction-set))
-  (assemble-instructions asm instructions)
+  (assemble-instructions! asm instructions)
-  (finalize-references asm)
+  (assembler-backpatch! asm)
   (assembler-dump-program asm port))

scmvm/language/scheme.scm

@@ -2,6 +2,7 @@
   #:use-module (scmvm assembler)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -110,7 +111,7 @@
    [(define? (car prgm))
     (let-values ([(bindings cont) (collect-bindings prgm)])
       `(letrec ,bindings ,(desugar-body cont)))]
-   [else (cons (desugar-exp (car prgm)) (desugar-top (cdr exp)))]))
+   [else (cons (desugar-exp (car prgm)) (desugar-top (cdr prgm)))]))
 
 (define (desugar-exp exp)
   (match exp
@@ -194,7 +195,8 @@
     [ ('letrec ([v* e*] ...) body)
       (let-values ([(r0 v*0) (uniq-names r v*)])
         (T*-k e* (lambda ($e*)
-                   (T-k body (lambda ($body) `(letrec ,(zip v*0 $e*) (,c ,$body))) r0))
+                   `(letrec ,(zip v*0 $e*)
+                      ,(T-c body c r0)))
              r0))]
     [ ('begin e) (T-c e c r)]
     [ ('begin e e* ...)
@@ -226,7 +228,7 @@
   ;; (expr * (aexp -> cexp) -> cexp)
   (match expr
     [('quote e) (k expr)]
-    [`(lambda . ,_) (k (M expr r))]
+    [('lambda . _) (k (M expr r))]
     [(? atomic?)   (k (M expr r))]
     [('letrec ([v* e*] ...) body)
      (let-values ([(r0 v*0) (uniq-names r v*)])
@@ -256,13 +258,12 @@
        (T-k e (lambda ($e)
                 `(set-then! ,v0 ,$e ,(k undefined-value))) r))]
     [(f e* ...)
-     (let* ([$rv (gensym "$rv-")]
+     (let ([$rv (gensym "$rv-")])
-            [$k  (gensym "$k-")])
        (T-k f
             (lambda ($f)
               (T*-k e*
                     (lambda ($e*)
-                      (k `((lambda (,$k) (,$f ,@$e* ,$k)) (lambda (,$rv) ,$rv))))
+                      `(,$f ,@$e* (lambda (,$rv) ,(k $rv))))
                     r))
             r))]))
 
@@ -287,6 +288,10 @@
         [(args ... k) (k (apply x args))])
       x))
 
+(define (set-then! v e k)
+  (set! v e)
+  (k undefined-value))
+
 (define (ir-interpreter)
   (display "> ")
   (let ([prgm (read)])
@@ -294,6 +299,64 @@
     (primitive-eval `(display (call/cc (lambda (ktail) ,(ir-convert prgm)))))
     (newline))
   (ir-interpreter))
+
+ ;; Optimization
+(define-syntax-rule (define-cps-type name field ...)
+  (begin
+    (define-cps-record-type name field ...)
+    (set-record-type-printer! name cps-printer)))
+
+(define-syntax define-cps-record-type
+  (lambda (ctx)
+    (define (syntax-append id . syns)
+      (datum->syntax id (apply symbol-append (map syntax->datum syns))))
+    (syntax-case ctx ()
+      [(_ name field ...)
+       (with-syntax ([ctor (syntax-append #'name #'make- #'name)]
+                     [pred (syntax-append #'name #'name #'?)]
+                     [(getter ...) (map (lambda (f) (syntax-append f #'name #'- f))
+                                        #'(field ...))])
+         #'(define-record-type name
+             (ctor field ...)
+             pred
+             (field getter) ...))])))
+
+(define (cps-printer cps port)
+  (format port "<cps ~s>" (unparse-cps cps)))
+
+(define-cps-type $constant val)
+(define-cps-type $primitive name)
+(define-cps-type $var name)
+(define-cps-type $abstraction vars body ktail)
+(define-cps-type $alternative pred kt kf)
+(define-cps-type $fix vars exps body)
+(define-cps-type $assignment var exp cont)
+(define-cps-type $application f args ktail)
+
+(define (parse-cps exp)
+  (match exp
+    [(? constant?) (make-$constant exp)]
+    [('cps-prim name) (make-$primitive name)]
+    [(? symbol?) (make-$var exp)]
+    [('lambda (vars ... ktail) body) (make-$abstraction (map parse-cps vars) (parse-cps body) ktail)]
+    [('if pred k1 k2) (make-$alternative (parse-cps pred) k1 k2)]
+    [('letrec ([vars exps] ...) body) (make-$fix (map parse-cps vars) (map parse-cps exps) (parse-cps body))]
+    [('set!-then var exp cont) (make-$assignment var (parse-cps exp) (parse-cps cont))]
+    [(f args ... ktail) (make-$application (parse-cps f) (map parse-cps args) ktail)]
+    [_ (error "unexpected cps while parsing" exp)]))
+
+(define (unparse-cps exp)
+  (match exp
+    [($ $constant val) val]
+    [($ $primitive name) `(cps-prim ,name)]
+    [($ $var name) name]
+    [($ $abstraction vars body ktail) `(lambda (,@(map unparse-cps vars) ,ktail) ,(unparse-cps body))]
+    [($ $alternative pred kt kf) `(if ,(unparse-cps pred) ,kt ,kf)]
+    [($ $fix vars exps body) `(letrec ,(zip (map unparse-cps vars) (map unparse-cps exps)) ,(unparse-cps body))]
+    [($ $assignment var expr cont) `(set!-then ,(unparse-cps var) ,(unparse-cps expr) ,(unparse-cps cont))]
+    [($ $application fun args ktail) `(,(unparse-cps fun) ,@(map unparse-cps args) ,ktail)]
+    [_ (error "Unexpected cps while unparsing" exp)]))
+
  ;; Compilation
 
 (define (meaning e r)

scmvm/util/stack.scm

@@ -0,0 +1,74 @@
+(define-module (scmvm util stack)
+  #:use-module (srfi srfi-43)
+  #:replace (make-stack)
+  #:export (stack-ref stack->list stack-set!
+            (push . stack-push) (pop . stack-pop) (peek . stack-peek) (swap . stack-swap)))
+
+;; Stack data structure. I made this a closure implementation for some reason
+
+(define *stack-size* 512)
+
+(define* (make-stack #:optional (stack-size *stack-size*))
+  "Make a new stack, optionally setting the size"
+  (define the-stack (make-vector stack-size))
+  (define top 0)
+  (lambda (x)
+    (case x
+      [(push)
+       (lambda (v)
+         (if (>= top stack-size)
+             (error "stack overflow")
+             (begin
+               (vector-set! the-stack top v)
+               (set! top (1+ top)))))]
+      [(pop)
+       (lambda ()
+         (if (zero? top)
+             (error "pop empty stack")
+             (begin
+               (set! top (1- top))
+               (vector-ref the-stack top))))]
+      [(peek)
+       (lambda ()
+         (if (zero? top)
+             (error "peek empty stack")
+             (vector-ref the-stack (1- top))))]
+      [(swap)
+       (lambda ()
+         (if (< (vector-length the-stack) 2)
+             (error "no value to swap")
+             (let ([a (vector-ref the-stack (- top 2))]
+                   [b (vector-ref the-stack (- top 1))])
+               (vector-set! the-stack (- top 2) b)
+               (vector-set! the-stack (- top 1) a))))]
+      [(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)
+  ((stack 'push) v))
+
+(define (pop stack)
+  ((stack 'pop)))
+
+(define (peek stack)
+  ((stack 'peek)))
+
+(define (swap stack)
+  ((stack 'swap)))
+
+(define (stack-ref stack k)
+  ((stack 'ref) k))
+
+(define (stack->list stack)
+  ((stack '->list)))
+
+(define (stack-set! stack k obj)
+  ((stack 'set!) k obj))

scmvm/vm.scm

@@ -1,280 +1,39 @@
 (define-module (scmvm vm)
-  #:use-module ((scheme base)
+  #:use-module (ice-9 hash-table)
-                #:select (read-u8 read-bytevector))
+  #:export (define-instruction-set
-  #:use-module (rnrs bytevectors)
+             instruction-lookup
-  #:use-module (srfi srfi-1)
+             instruction-set-caller
-  #:use-module (srfi srfi-9)
+             instruction-name
-  #:use-module (srfi srfi-26)
+             instruction-code
-  #:use-module (srfi srfi-43)
+             register-set))
-  #: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-name instruction-code))
-
-;;; Data Structures
-(define *stack-size* 512)
-(define *memory-size* 2048)
 
-(define* (make-stack #:optional (stack-size *stack-size*))
-  "Make a new stack, optionally setting the size"
-  (define the-stack (make-vector stack-size))
-  (define top 0)
-  (lambda (x)
-    (case x
-      [(push)
-       (lambda (v)
-         (if (>= top stack-size)
-             (error "stack overflow")
-             (begin
-               (vector-set! the-stack top v)
-               (set! top (1+ top)))))]
-      [(pop)
-       (lambda ()
-         (if (zero? top)
-             (error "pop empty stack")
-             (begin
-               (set! top (1- top))
-               (vector-ref the-stack top))))]
-      [(peek)
-       (lambda ()
-         (if (zero? top)
-             (error "peek empty stack")
-             (vector-ref the-stack (1- top))))]
-      [(swap)
-       (lambda ()
-         (if (< (vector-length the-stack) 2)
-             (error "no value to swap")
-             (let ([a (vector-ref the-stack (- top 2))]
-                   [b (vector-ref the-stack (- top 1))])
-               (vector-set! the-stack (- top 2) b)
-               (vector-set! the-stack (- top 1) a))))]
-      [(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)
-  ((stack 'push) v))
-
-(define (pop stack)
-  ((stack 'pop)))
-
-(define (peek stack)
-  ((stack 'peek)))
-
-(define (swap stack)
-  ((stack 'swap)))
-
-(define (stack-ref stack k)
-  ((stack 'ref) k))
-
-(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)
-  "Read the next 32-bit value from (current-input-port)"
-  (let ([bv (read-bytevector 4)])
-    (bytevector-s32-ref bv 0 (native-endianness))))
-
 ;;; Instructions
-(define *instruction-set*
+(define-syntax define-instruction-set
-  '((push   #x01)
+  (syntax-rules (define-instruction)
-    (!      #x02)
+    [(_ (set-name reg ...) (define-instruction (name opcode) impl ...) ...)
-    (@      #x03)
+     (define (set-name dispatch)
-    (+      #x04)
+       (case dispatch
-    (-      #x05)
+         [(lookup)
-    (and    #x06)
+          (lambda (lookup)
-    (or     #x07)
+            (case lookup
-    (nand   #x08)
+              [(name) '(name opcode)] ...
-    (nor    #x09)
+              [else #f]))]
-    (xor    #x0a)
+         [(call)
-    (=      #x0b)
+          (lambda (registers)
-    (>      #x0c)
+            (let ([reg (hash-ref registers 'reg)] ...)
-    (<      #x0d)
+              (parameterize ([reg #f] ...)
-    (jmp    #x0e)
+                (lambda (op)
-    (branch #x0f)
+                  (case op
-    (call   #x10)
+                    [(opcode) impl ...] ...)))))]))]))
-    (return #x11)
+
-    (>R     #x12)
+(define (instruction-lookup isa name)
-    (R>     #x13)
+  ((isa 'lookup) name))
-    (drop   #x14)
+
-    (nip    #x15)
+(define (instruction-set-caller instruction-set registers)
-    (dup    #x16)
+  ((instruction-set 'call) registers))
-    (swap   #x17)
-    (rot    #x18)
-    (over   #x19)
-    (not    #x1a)
-    (set!    #x1b)
-    (bye    #xff)))
 
 (define instruction-name car)
 (define instruction-code cadr)
 
-(define (op-lookup code)
+(define (register-set names)
-  (let ([op (find (lambda (x) (= (instruction-code x) code)) *instruction-set*)])
+  (alist->hash-table (map (lambda (n) (cons n (make-parameter #f))) names)))
-    (if op
-	(car op)
-	(error (format #f "tried to execute non-existant instruction ~x" code)))))
-
-(define (binop-lookup op)
-  (case (op-lookup op)
-    [(+) +]
-    [(-) -]
-    [(and) logand]
-    [(or) logior]
-    [(nand) (compose lognot logand)]
-    [(nor) (compose lognot logior)]
-    [(xor) logxor]
-    [(not) lognot]))
-
-(define (relop-lookup op)
-  (case (op-lookup op)
-    [(>) >]
-    [(<) <]
-    [(=) =]))
-
-
-(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)))
-  (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 (vm-pc vm))])
-      (vm-pc-set! vm (+ (vm-pc vm) 1))
-      byte))
-  (define (fetch-word)
-    (let ([word (ram-word-ref (vm-pc vm))])
-      (vm-pc-set! vm (+ (vm-pc vm) 4))
-      word))
-  (when debugger
-    (debugger))
-  (define op (fetch-byte))
-  (case (op-lookup op)
-    [(push)
-     (push data-stack (fetch-word))]
-    [(!)
-     (let ([addr (pop data-stack)]
-           [v (pop data-stack)])
-       (ram-word-set! addr v))]
-    [(@)
-     (let* ([addr (pop data-stack)]
-            [v (ram-word-ref addr)])
-       (push data-stack v))]
-    [(+ - and or nand nor xor)
-     (let ([v2 (pop data-stack)]
-           [v1 (pop data-stack)])
-       (push data-stack ((binop-lookup op) v1 v2)))]
-    [(= > <)
-     (let ([v2 (pop data-stack)]
-           [v1 (pop data-stack)])
-       (if ((relop-lookup op) v1 v2)
-           (push data-stack 1)
-           (push data-stack 0)))]
-    [(jmp)
-     (jump (pop data-stack))]
-    [(branch)
-     (let ([addr (pop data-stack)])
-       (when (zero? (pop data-stack))
-         (jump addr)))]
-    [(call)
-     (let ([addr (pop data-stack)])
-       (push ret-stack (vm-pc vm))
-       (jump addr))]
-    [(return)
-     (jump (pop ret-stack))]
-    [(>R)
-     (push ret-stack (pop data-stack))]
-    [(R>)
-     (push data-stack (pop ret-stack))]
-    [(drop)
-     (pop data-stack)]
-    [(nip)
-     (let ([v (pop data-stack)])
-       (pop data-stack)
-       (push data-stack v))]
-    [(dup)
-     (push data-stack (peek data-stack))]
-    [(swap)
-     (swap data-stack)]
-    [(rot)
-     (let* ([a (pop data-stack)]
-            [b (pop data-stack)]
-            [c (pop data-stack)])
-       (push data-stack a)
-       (push data-stack c)
-       (push data-stack b))]
-    [(over)
-     (let* ([a (pop data-stack)]
-            [b (pop data-stack)])
-       (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)))
-
-(define (vm-memory-ref vm 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)
-  (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-memory vm)])
-    (bytevector-copy! prgm 0
-                      ram 0
-                      (bytevector-length prgm))))

scmvm/vm/forth.scm

@@ -0,0 +1,279 @@
+(define-module (scmvm vm forth)
+  #:use-module (scmvm vm)
+  #:use-module (scmvm util stack)
+  #:use-module ((scheme base)
+                #:select (read-u8 read-bytevector))
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-9)
+  #:export ((make-forth-vm* . make-forth-vm)
+            forth-instruction-set
+            forth-vm-load-program!
+            forth-vm-run!
+            forth-vm-pc
+            forth-vm-pc-set!
+            forth-vm-memory-set!
+            forth-vm-memory-ref
+            forth-vm-data-stack))
+
+;;; IO
+(define *memory-size* 2048)
+
+(define* (make-ram #:optional (memory-size *memory-size*))
+  (make-bytevector memory-size #x00))
+
+(define (read-word)
+  "Read the next 32-bit value from (current-input-port)"
+  (let ([bv (read-bytevector 4)])
+    (bytevector-s32-ref bv 0 (native-endianness))))
+
+
+;;; VM
+(define-record-type <forth-vm>
+  (make-forth-vm instruction-set registers)
+  forth-vm?
+  (instruction-set forth-vm-instruction-set)
+  (registers forth-vm-registers forth-vm-registers-set!))
+
+(define* (make-forth-vm* instruction-set #:key stack-size memory-size)
+  "Create a fresh VM, with optional stack and memory sizes"
+  (define registers (register-set '(*data-stack* *ret-stack* *pc* *ram* *vm-exit*)))
+  ((hash-ref registers '*pc*) 1)
+  ((hash-ref registers '*data-stack*) (if stack-size (make-stack stack-size) (make-stack)))
+  ((hash-ref registers '*ret-stack*) (if stack-size (make-stack stack-size) (make-stack)))
+  ((hash-ref registers '*ram*) (if memory-size (make-ram memory-size) (make-ram)))
+  (make-forth-vm instruction-set registers))
+
+(define *vm* (make-parameter #f))
+
+(define-syntax-rule (with-forth-vm-registers (reg ...) expr ...)
+  (let ([reg (hash-ref (forth-vm-registers (*vm*)) 'reg)] ...)
+    expr ...))
+
+(define (ram-word-ref k)
+  (with-forth-vm-registers
+   (*ram*)
+   (if (< k 1)
+       (error "null memory read")
+       (bytevector-s32-native-ref (*ram*) (1- k)))))
+
+(define (ram-byte-ref k)
+  (with-forth-vm-registers
+   (*ram*)
+   (if (< k 1)
+       (error "null memory read")
+       (bytevector-u8-ref (*ram*) (1- k)))))
+
+(define (ram-word-set! k v)
+  (with-forth-vm-registers
+   (*ram*)
+   (if (< k 1)
+       (error "null memory write")
+       (bytevector-s32-native-set! (*ram*) (1- k) v))))
+
+(define (jump! x)
+  (with-forth-vm-registers
+   (*pc*)
+   (*pc* (logand #x2fffffff x))))
+
+(define (fetch-byte!)
+  (with-forth-vm-registers
+   (*pc*)
+   (let* ([byte (ram-byte-ref (*pc*))])
+     (*pc* (+ (*pc*) 1))
+     byte)))
+
+(define (fetch-word!)
+  (with-forth-vm-registers
+   (*ram* *pc*)
+   (let* ([word (ram-word-ref (*pc*))])
+     (*pc* (+ (*pc*) 4))
+     word)))
+
+(define (forth-vm-pc vm)
+  (parameterize ([*vm* vm])
+    (with-forth-vm-registers
+     (*pc*)
+     (*pc*))))
+
+(define (forth-vm-pc-set! vm k)
+  (parameterize ([*vm* vm])
+    (with-forth-vm-registers
+     (*pc*)
+     (*pc* k))))
+
+(define (forth-vm-memory-set! vm k v)
+  (parameterize ([*vm* vm])
+    (ram-word-set! k v)))
+
+(define (forth-vm-memory-ref vm k)
+  (parameterize ([*vm* vm])
+    (with-forth-vm-registers
+     (*ram*)
+     (ram-word-ref k))))
+
+(define (forth-vm-data-stack vm)
+  (parameterize ([*vm* vm])
+    (with-forth-vm-registers
+     (*data-stack*)
+     (*data-stack*))))
+
+ ;;; Instruction set
+(define-instruction-set (forth-instruction-set *pc* *ram* *data-stack* *ret-stack* *vm-exit*)
+  (define-instruction (push #x01)
+    (stack-push (*data-stack*) (fetch-word!)))
+  
+  (define-instruction (! #x02)
+    (let ([addr (stack-pop (*data-stack*))]
+          [v (stack-pop (*data-stack*))])
+      (ram-word-set! addr v)))
+  
+  (define-instruction (@ #x03)
+    (let* ([addr (stack-pop (*data-stack*))]
+           [v (ram-word-ref addr)])
+      (stack-push (*data-stack*) v)))
+  
+  (define-instruction (+ #x04)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (+ v1 v2))))
+  
+  (define-instruction (- #x05)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (- v1 v2))))
+  
+  (define-instruction (and #x06)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (logand v1 v2))))
+
+  (define-instruction (or #x07)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (logior v1 v2))))
+
+  (define-instruction (nand #x08)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (if (zero? (logand v1 v2)) 1 0))))
+
+  (define-instruction (nor #x09)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (if (zero? (logior v1 v2)) 1 0))))
+
+  (define-instruction (xor #x0a)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (logxor v1 v2))))
+
+  (define-instruction (= #x0b)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (if (= v1 v2)
+          (stack-push (*data-stack*) 1)
+          (stack-push (*data-stack*) 0))))
+
+  (define-instruction (> #x0c)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (if (> v1 v2)
+          (stack-push (*data-stack*) 1)
+          (stack-push (*data-stack*) 0))))
+
+  (define-instruction (< #x0d)
+    (let ([v2 (stack-pop (*data-stack*))]
+          [v1 (stack-pop (*data-stack*))])
+      (if (< v1 v2)
+          (stack-push (*data-stack*) 1)
+          (stack-push (*data-stack*) 0))))
+
+  (define-instruction (jmp #x0e)
+    (jump! (stack-pop (*data-stack*))))
+
+  (define-instruction (branch #x0f)
+    (let* ([addr (stack-pop (*data-stack*))]
+           [test (stack-pop (*data-stack*))])
+      (when (zero? test)
+        (jump! addr))))
+
+  (define-instruction (call #x10)
+    (let ([addr (stack-pop (*data-stack*))])
+      (stack-push (*ret-stack*) (*pc*))
+      (jump! addr)))
+
+  (define-instruction (return #x11)
+    (jump! (stack-pop (*ret-stack*))))
+
+  (define-instruction (>R #x12)
+    (stack-push (*ret-stack*) (stack-pop (*data-stack*))))
+
+  (define-instruction (R> #x13)
+    (stack-push (*data-stack*) (stack-pop (*ret-stack*))))
+
+  (define-instruction (drop #x14)
+    (stack-pop (*data-stack*)))
+
+  (define-instruction (nip #x15)
+    (let ([v (stack-pop (*data-stack*))])
+      (stack-pop (*data-stack*))
+      (stack-push (*data-stack*) v)))
+
+  (define-instruction (dup #x16)
+    (stack-push (*data-stack*) (stack-peek (*data-stack*))))
+
+  (define-instruction (swap #x17)
+    (stack-swap (*data-stack*)))
+
+  (define-instruction (rot #x18)
+    (let* ([a (stack-pop (*data-stack*))]
+           [b (stack-pop (*data-stack*))]
+           [c (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) a)
+      (stack-push (*data-stack*) c)
+      (stack-push (*data-stack*) b)))
+
+  (define-instruction (over #x19)
+    (let* ([a (stack-pop (*data-stack*))]
+           [b (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) b)
+      (stack-push (*data-stack*) a)
+      (stack-push (*data-stack*) b)))
+
+  (define-instruction (not #x1a)
+    (let ([a (stack-pop (*data-stack*))])
+      (stack-push (*data-stack*) (if (zero? a) 1 0))))
+
+  (define-instruction (set! #x1b)
+    ;; use let* to induce an order of evaluation
+    (let* ([idx (stack-pop (*data-stack*))]
+           [obj (stack-pop (*data-stack*))])
+      (stack-set! (*data-stack*) idx obj)))
+
+  (define-instruction (bye #xff)
+    (*vm-exit* #t)))
+
+;;; Execution
+(define* (forth-vm-run! vm #:optional debugger)
+  "Begin execution at pc"
+  (define caller (instruction-set-caller (forth-vm-instruction-set vm)
+                                         (forth-vm-registers vm)))
+  (parameterize ([*vm* vm])
+    (with-forth-vm-registers
+     (*vm-exit*)
+     (let lp () 
+       (when debugger
+         (debugger))
+       (define op (fetch-byte!))
+       (caller op)
+       (unless (*vm-exit*) (lp))))))
+
+(define (forth-vm-load-program! vm prgm)
+  "Loads the bytevector into the vm, starting at memory address 1"
+  (parameterize ([*vm* vm])
+    (with-forth-vm-registers
+     (*ram*)
+     (let ([ram (*ram*)])
+       (bytevector-copy! prgm 0
+                         ram 0
+                         (bytevector-length prgm))))))

tests.scm

@@ -1,6 +1,7 @@
 (use-modules (d- test)
 	     (scmvm assembler)
-             (scmvm vm)
+             (scmvm vm forth)
+             (scmvm util stack)
 	     (scmvm debugger)
 	     (scmvm language assembly)
 	     (scmvm language scheme)
@@ -110,60 +111,60 @@
 (define-test-suite "assembly"
   (define-test "adder"
     (define out (open-output-bytevector))
-    (assemble adder-program-assembly out)
+    (assemble adder-program-assembly forth-instruction-set out)
     (assert-equal adder-program-bytecode (get-output-bytevector out)))
   (define-test "fib"
     (define out (open-output-bytevector))
-    (assemble fib-program-assembly out)
+    (assemble fib-program-assembly forth-instruction-set out)
     (assert-equal fib-program-bytecode (get-output-bytevector out))))
 
 (define-test-suite "vm"
   (define-test "adder"
-    (define my-vm (make-vm))
+    (define my-vm (make-forth-vm forth-instruction-set))
-    (vm-load-program! my-vm adder-program-bytecode)
+    (forth-vm-load-program! my-vm adder-program-bytecode)
-    (vm-pc-set! my-vm 5)
+    (forth-vm-pc-set! my-vm 5)
-    (run-vm my-vm)
+    (forth-vm-run! my-vm)
-    (assert-equal 3 (vm-memory-ref my-vm 1)))
+    (assert-equal 3 (forth-vm-memory-ref my-vm 1)))
   (define-test "fib"
-    (define my-vm (make-vm))
+    (define my-vm (make-forth-vm forth-instruction-set))
-    (vm-load-program! my-vm fib-program-bytecode)
+    (forth-vm-load-program! my-vm fib-program-bytecode)
-    (vm-memory-set! my-vm 1 10)
+    (forth-vm-memory-set! my-vm 1 10)
-    (vm-pc-set! my-vm 5)
+    (forth-vm-pc-set! my-vm 5)
-    (run-vm my-vm)
+    (forth-vm-run! my-vm)
-    (assert-equal 55 (vm-memory-ref my-vm 1))))
+    (assert-equal 55 (forth-vm-memory-ref my-vm 1))))
 
 (define-test-suite "debugger"
   (define-test "modify-running-program"
-    (define fib-program-asm (make-assembler))
+    (define fib-program-asm (make-assembler forth-instruction-set))
-    (assemble-instructions fib-program-asm fib-program-assembly)
+    (assemble-instructions! fib-program-asm fib-program-assembly)
-    (finalize-references fib-program-asm)
+    (assembler-backpatch! fib-program-asm)
-    (define my-debugger (make-debugger fib-program-asm))
+    (define my-debugger (make-forth-debugger fib-program-asm))
     (define my-vm (debugger-vm my-debugger))
-    (define my-data (vm-data-stack my-vm))
+    (define my-data (forth-vm-data-stack my-vm))
-    (vm-memory-set! my-vm 1 10)
+    (forth-vm-memory-set! my-vm 1 10)
-    (vm-pc-set! my-vm 5)
+    (forth-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)))
+    (assert-equal 1 (forth-vm-memory-ref my-vm 1)))
   (define-test "stepping"
-    (define fib-program-asm (make-assembler))
+    (define fib-program-asm (make-assembler forth-instruction-set))
-    (assemble-instructions fib-program-asm fib-program-assembly)
+    (assemble-instructions! fib-program-asm fib-program-assembly)
-    (finalize-references fib-program-asm)
+    (assembler-backpatch! fib-program-asm)
-    (define my-debugger (make-debugger fib-program-asm))
+    (define my-debugger (make-forth-debugger fib-program-asm))
     (define my-vm (debugger-vm my-debugger))
-    (vm-memory-set! my-vm 1 10)
+    (forth-vm-memory-set! my-vm 1 10)
-    (vm-pc-set! my-vm 5)
+    (forth-vm-pc-set! my-vm 5)
     (debugger-breakpoint-add! my-debugger 'fib)
     (debugger-continue my-debugger)
-    (assert-equal 23 (vm-pc my-vm))
+    (assert-equal 23 (forth-vm-pc my-vm))
     (debugger-step my-debugger)
-    (assert-equal 24 (vm-pc my-vm)) ;; dup is a 1 byte instruction
+    (assert-equal 24 (forth-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
+    (assert-equal 29 (forth-vm-pc my-vm)) ;; push is a 5 byte instruction
     (debugger-continue my-debugger)
-    (assert-equal 23 (vm-pc my-vm)) ;; continue stops stepping
+    (assert-equal 23 (forth-vm-pc my-vm)) ;; continue stops stepping
     ))