Change vm from a closure to a record type for ease of use, expose data and ret stacks

scmvm/vm.scm

@@ -3,8 +3,12 @@
                 #: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!
+  #:export ((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))
 
@@ -126,36 +130,41 @@
     [(=) =]))
 
 
-;;; Execution
+(define-record-type <vm>
-(define* (make-vm #:key stack-size memory-size debugger)
+  (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)
+  (make-vm data-stack ret-stack ram 1 debugger))
-    (if (< k 1)
+
-        (error "null memory read")
+;;; Execution
-        (bytevector-s32-native-ref ram (1- k))))
+(define (run-vm vm)
-  (define (ram-byte-ref k)
+  "Begin execution at pc"
-    (if (< k 1)
+  (define data-stack (vm-data-stack vm))
-        (error "null memory read")
+  (define ret-stack (vm-ret-stack vm))
-        (bytevector-u8-ref ram (1- k))))
+  (define ram-word-ref (cute vm-memory-ref vm <>))
-  (define (ram-word-set! k v)
+  (define ram-byte-ref (cute vm-memory-byte-ref vm <>))
-    (if (< k 1)
+  (define ram-word-set! (cute vm-memory-set! vm <> <>))
-        (error "null memory write")
+  (define debugger (vm-debugger vm))
-        (bytevector-s32-native-set! ram (1- k) v)))
+  (define exit? #f)
-  (define pc 1)
+  (define (jump x) (vm-pc-set! vm x))
-  (define (jump x) (set! pc x))
   (define (fetch-byte)
-    (let ([byte (ram-byte-ref pc)])
+    (let ([byte (ram-byte-ref (vm-pc vm))])
-      (set! pc (+ pc 1))
+      (vm-pc-set! vm (+ (vm-pc vm) 1))
       byte))
   (define (fetch-word)
-    (let ([word (ram-word-ref pc)])
+    (let ([word (ram-word-ref (vm-pc vm))])
-      (set! pc (+ pc 4))
+      (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 +197,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))]
@@ -221,44 +230,24 @@
        (push data-stack b))]
     [(bye) (set! exit? #t)])
   (when (not exit?)
-      (fetch-and-execute)))
+    (run-vm vm)))
-  (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")])))
 
 (define (vm-memory-ref vm k)
-  "Externally access VM memory at k"
+  (if (< k 1)
-  ((vm 'vm-memory-ref) k))
+      (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"
+  (if (< k 1)
-  ((vm 'vm-memory-set!) k v))
+      (error "null memory write")
-
+      (bytevector-s32-native-set! (vm-memory vm) (1- k) v)))
-(define (vm-memory vm)
-  "Just get the memory vector"
-  ((vm 'vm-memory)))
 
 (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

@@ -120,12 +120,12 @@
     (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))))