dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Dane Johnson 2025-08-13 11:42:56 -05:00
parent d02bc02258
commit 9a8cd12c5d
2 changed files with 111 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

229
scmvm/vm.scm
View File

@ -3,8 +3,12 @@
#:select (read-u8 read-bytevector)) #:select (read-u8 read-bytevector))
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #: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! vm-pc vm-pc-set!
*instruction-set* instruction-type instruction-code)) *instruction-set* instruction-type instruction-code))
@ -126,139 +130,124 @@
[(=) =])) [(=) =]))
;;; 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" "Create a fresh VM, with optional stack and memory sizes"
(define data-stack (if stack-size (make-stack stack-size) (make-stack))) (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 ret-stack (if stack-size (make-stack stack-size) (make-stack)))
(define ram (if memory-size (make-ram memory-size) (make-ram))) (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) (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)) byte))
(define (fetch-word) (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)) word))
(define (fetch-and-execute) (when debugger
(define exit? #f) (debugger))
(when debugger (define op (fetch-byte))
(debugger)) (case (op-lookup op)
(define op (fetch-byte)) [(push)
(case (op-lookup op) (push data-stack (fetch-word))]
[(push) [(!)
(push data-stack (fetch-word))] (let ([addr (pop data-stack)]
[(!) [v (pop data-stack)])
(let ([addr (pop data-stack)] (ram-word-set! addr v))]
[v (pop data-stack)]) [(@)
(ram-word-set! addr v))] (let* ([addr (pop data-stack)]
[(@) [v (ram-word-ref addr)])
(let* ([addr (pop data-stack)] (push data-stack v))]
[v (ram-word-ref addr)]) [(+ - and or nand nor xor)
(push data-stack v))] (let ([v2 (pop data-stack)]
[(+ - and or nand nor xor) [v1 (pop data-stack)])
(let ([v2 (pop data-stack)] (push data-stack ((binop-lookup op) v1 v2)))]
[v1 (pop data-stack)]) [(= > <)
(push data-stack ((binop-lookup op) v1 v2)))] (let ([v2 (pop data-stack)]
[(= > <) [v1 (pop data-stack)])
(let ([v2 (pop data-stack)] (if ((relop-lookup op) v1 v2)
[v1 (pop data-stack)]) (push data-stack 1)
(if ((relop-lookup op) v1 v2) (push data-stack 0)))]
(push data-stack 1) [(jmp)
(push data-stack 0)))] (jump (pop data-stack))]
[(jmp) [(branch)
(jump (pop data-stack))] (let ([addr (pop data-stack)])
[(branch) (when (zero? (pop data-stack))
(let ([addr (pop data-stack)]) (jump addr)))]
(when (zero? (pop data-stack)) [(call)
(jump addr)))] (let ([addr (pop data-stack)])
[(call) (push ret-stack (vm-pc vm))
(let ([addr (pop data-stack)]) (jump addr))]
(push ret-stack pc) [(return)
(jump addr))] (jump (pop ret-stack))]
[(return) [(>R)
(jump (pop ret-stack))] (push ret-stack (pop data-stack))]
[(>R) [(R>)
(push ret-stack (pop data-stack))] (push data-stack (pop ret-stack))]
[(R>) [(drop)
(push data-stack (pop ret-stack))] (pop data-stack)]
[(drop) [(nip)
(pop data-stack)] (let ([v (pop data-stack)])
[(nip) (pop data-stack)
(let ([v (pop data-stack)]) (push data-stack v))]
(pop data-stack) [(dup)
(push data-stack v))] (push data-stack (peek data-stack))]
[(dup) [(swap)
(push data-stack (peek data-stack))] (swap data-stack)]
[(swap) [(rot)
(swap data-stack)] (let* ([a (pop data-stack)]
[(rot) [b (pop data-stack)]
(let* ([a (pop data-stack)] [c (pop data-stack)])
[b (pop data-stack)] (push data-stack a)
[c (pop data-stack)]) (push data-stack c)
(push data-stack a) (push data-stack b))]
(push data-stack c) [(over)
(push data-stack b))] (let* ([a (pop data-stack)]
[(over) [b (pop data-stack)])
(let* ([a (pop data-stack)] (push data-stack b)
[b (pop data-stack)]) (push data-stack a)
(push data-stack b) (push data-stack b))]
(push data-stack a) [(bye) (set! exit? #t)])
(push data-stack b))] (when (not exit?)
[(bye) (set! exit? #t)]) (run-vm vm)))
(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")])))
(define (vm-memory-ref vm k) (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) (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) (define (vm-load-program! vm prgm)
"Loads the bytevector into the vm, starting at memory address 1" "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 (bytevector-copy! prgm 0
ram 0 ram 0
(bytevector-length prgm)))) (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)))

4
tests.scm
View File

@ -120,12 +120,12 @@
(define my-vm (make-vm)) (define my-vm (make-vm))
(vm-load-program! my-vm adder-program-bytecode) (vm-load-program! my-vm adder-program-bytecode)
(vm-pc-set! my-vm 5) (vm-pc-set! my-vm 5)
((my-vm 'vm-run)) (run-vm my-vm)
(assert-equal 3 (vm-memory-ref my-vm 1))) (assert-equal 3 (vm-memory-ref my-vm 1)))
(define-test "fib" (define-test "fib"
(define my-vm (make-vm)) (define my-vm (make-vm))
(vm-load-program! my-vm fib-program-bytecode) (vm-load-program! my-vm fib-program-bytecode)
(vm-memory-set! my-vm 1 10) (vm-memory-set! my-vm 1 10)
(vm-pc-set! my-vm 5) (vm-pc-set! my-vm 5)
((my-vm 'vm-run)) (run-vm my-vm)
(assert-equal 55 (vm-memory-ref my-vm 1)))) (assert-equal 55 (vm-memory-ref my-vm 1))))