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

Pluggable instruction sets

Browse Source
This commit is contained in:
Dane Johnson
2026-02-10 10:58:48 -06:00
parent e4fe2c6bff
commit 4280841719
6 changed files with 226 additions and 188 deletions
Download Patch File Download Diff File Expand all files Collapse all files

320
scmvm/vm.scm
View File

@@ -13,7 +13,9 @@
vm-data-stack vm-ret-stack
vm-debugger vm-debugger-set!
vm-pc vm-pc-set!
*instruction-set* instruction-name instruction-code))
vm-instruction-set
instruction-lookup instruction-name instruction-code
forth-instruction-set))
;;; Data Structures
(define *stack-size* 512)
@@ -95,169 +97,201 @@
(bytevector-s32-ref bv 0 (native-endianness))))
;;; Instructions
(define *instruction-set*
'((push #x01)
(! #x02)
(@ #x03)
(+ #x04)
(- #x05)
(and #x06)
(or #x07)
(nand #x08)
(nor #x09)
(xor #x0a)
(= #x0b)
(> #x0c)
(< #x0d)
(jmp #x0e)
(branch #x0f)
(call #x10)
(return #x11)
(>R #x12)
(R> #x13)
(drop #x14)
(nip #x15)
(dup #x16)
(swap #x17)
(rot #x18)
(over #x19)
(not #x1a)
(set! #x1b)
(bye #xff)))
(define-syntax define-instruction-set
(syntax-rules (define-instruction)
[(_ set-name (define-instruction (name opcode) impl ...) ...)
(define (set-name dispatch)
(case dispatch
[(lookup)
(lambda (lookup)
(case lookup
[(name) '(name opcode)] ...
[else #f]))]
[(call)
(lambda (op)
(case op
[(opcode) impl ...] ...))]))]))
(define (instruction-lookup isa name)
((isa 'lookup) name))
(define (instruction-set-call isa op)
((isa 'call) op))
(define instruction-name car)
(define instruction-code cadr)
(define (op-lookup code)
(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)
[(+) +]
[(-) -]
[(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-instruction-set forth-instruction-set
(define-instruction (push #x01)
(push (*data-stack*) (fetch-word!)))
(define-instruction (! #x02)
(let ([addr (pop (*data-stack*))]
[v (pop (*data-stack*))])
(ram-word-set! addr v)))
(define-instruction (@ #x03)
(let* ([addr (pop (*data-stack*))]
[v (ram-word-ref addr)])
(push (*data-stack*) v)))
(define-instruction (+ #x04)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(push (*data-stack*) (+ v1 v2))))
(define-instruction (- #x05)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(push (*data-stack*) (- v1 v2))))
(define-instruction (and #x06)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(push (*data-stack*) (logand v1 v2))))
(define-instruction (or #x07)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(push (*data-stack*) (logior v1 v2))))
(define-instruction (nand #x08)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(push (*data-stack*) (if (zero? (logand v1 v2)) 1 0))))
(define-instruction (nor #x09)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(push (*data-stack*) (if (zero? (logior v1 v2)) 1 0))))
(define-instruction (xor #x0a)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(push (*data-stack*) (logxor v1 v2))))
(define-instruction (= #x0b)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(if (= v1 v2)
(push (*data-stack*) 1)
(push (*data-stack*) 0))))
(define-instruction (> #x0c)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(if (> v1 v2)
(push (*data-stack*) 1)
(push (*data-stack*) 0))))
(define-instruction (< #x0d)
(let ([v2 (pop (*data-stack*))]
[v1 (pop (*data-stack*))])
(if (< v1 v2)
(push (*data-stack*) 1)
(push (*data-stack*) 0))))
(define-instruction (jmp #x0e)
(jump! (pop (*data-stack*))))
(define-instruction (branch #x0f)
(let* ([addr (pop (*data-stack*))]
[test (pop (*data-stack*))])
(when (zero? test)
(jump! addr))))
(define-instruction (call #x10)
(let ([addr (pop (*data-stack*))])
(push (*ret-stack*) (vm-pc (*vm*)))
(jump! addr)))
(define-instruction (return #x11)
(jump! (pop (*ret-stack*))))
(define-instruction (>R #x12)
(push (*ret-stack*) (pop (*data-stack*))))
(define-instruction (R> #x13)
(push (*data-stack*) (pop (*ret-stack*))))
(define-instruction (drop #x14)
(pop (*data-stack*)))
(define-instruction (nip #x15)
(let ([v (pop (*data-stack*))])
(pop (*data-stack*))
(push (*data-stack*) v)))
(define-instruction (dup #x16)
(push (*data-stack*) (peek (*data-stack*))))
(define-instruction (swap #x17)
(swap (*data-stack*)))
(define-instruction (rot #x18)
(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)))
(define-instruction (over #x19)
(let* ([a (pop (*data-stack*))]
[b (pop (*data-stack*))])
(push (*data-stack*) b)
(push (*data-stack*) a)
(push (*data-stack*) b)))
(define-instruction (not #x1a)
(let ([a (pop (*data-stack*))])
(push (*data-stack*) (if (zero? a) 1 0))))
(define-instruction (set! #x1b)
;; use let* to induce an order of evaluation
(let* ([idx (pop (*data-stack*))]
[obj (pop (*data-stack*))])
(stack-set! (*data-stack*) idx obj)))
(define-instruction (bye #xff)
(*vm-exit* #t)))
;;; VM
(define-record-type <vm>
(make-vm data-stack ret-stack memory pc debugger)
(make-vm data-stack ret-stack memory pc debugger instruction-set)
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!))
(debugger vm-debugger vm-debugger-set!)
(instruction-set vm-instruction-set vm-instruction-set-set!))
(define* (make-vm* #:key stack-size memory-size debugger)
(define* (make-vm* instruction-set #: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))
(define isa (if instruction-set instruction-set forth-instruction-set))
(make-vm data-stack ret-stack ram 1 debugger isa))
(define *vm* (make-parameter #f))
(define *data-stack* (make-parameter #f))
(define *ret-stack* (make-parameter #f))
(define *vm-exit* (make-parameter #f))
(define (ram-word-ref k)
(vm-memory-ref (*vm*) k))
(define (ram-byte-ref k)
(vm-memory-byte-ref (*vm*) k))
(define (ram-word-set! k v)
(vm-memory-set! (*vm*) k v))
(define (jump! x)
(vm-pc-set! (*vm*) (logand #x2fffffff x)))
(define (fetch-byte!)
(let* ([vm (*vm*)]
[byte (ram-byte-ref (vm-pc vm))])
(vm-pc-set! vm (+ (vm-pc vm) 1))
byte))
(define (fetch-word!)
(let* ([vm (*vm*)]
[word (ram-word-ref (vm-pc vm))])
(vm-pc-set! vm (+ (vm-pc vm) 4))
word))
;;; 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)))
(parameterize ([*vm* vm]
[*data-stack* (vm-data-stack vm)]
[*ret-stack* (vm-ret-stack vm)]
[*vm-exit* #f])
(define debugger (vm-debugger vm))
(let lp ()
(when debugger
(debugger))
(define op (fetch-byte!))
(instruction-set-call (vm-instruction-set (*vm*)) op)
(unless (*vm-exit*) (lp)))))
(define (vm-memory-ref vm k)
(if (< k 1)