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

All is one-op instructions (save push). Code in memory (this will allow compilation)

Browse Source
This commit is contained in:
Dane Johnson
2025-06-05 14:22:12 -05:00
parent 11eae06995
commit 679b53d76e
3 changed files with 204 additions and 137 deletions
Download Patch File Download Diff File Expand all files Collapse all files

172
scmvm/vm.scm
View File

@@ -4,7 +4,8 @@
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (make-vm run-vm vm-memory-ref vm-memory-set! vm-memory
#:export (make-vm run-vm vm-memory-ref vm-memory-set! vm-memory vm-load-program!
vm-pc-ref vm-pc-set!
*instruction-set* instruction-type instruction-code))
;;; Data Structures
@@ -65,13 +66,8 @@
((stack 'ref) k))
(define* (make-ram #:optional (memory-size *memory-size*))
(make-vector memory-size #x00))
(make-bytevector memory-size #x00))
(define (ram-ref ram k)
(vector-ref ram k))
(define (ram-set! ram k v)
(vector-set! ram k v))
;;; IO
(define (read-word)
@@ -81,31 +77,34 @@
;;; Instructions
(define *instruction-set*
'((push #x01 i)
(pop #x02 o)
(store #x03 i)
(load #x04 i)
(+ #x05 o)
(- #x06 o)
(and #x07 o)
(or #x08 o)
(nand #x09 o)
(nor #x0a o)
(xor #x0b o)
(if #x0c j)
(call #x0d j)
(return #x0e o)
(>R #x0f o)
(R> #x10 o)
(= #x11 o)
(> #x12 o)
(< #x13 o)
(dup #x14 o)
(swap #x15 o)
(jmp #x16 j)))
'((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)
(bye #xff)))
(define instruction-code cadr)
(define instruction-type caddr)
(define (op-lookup code)
(car (find (lambda (x) (= (instruction-code x) code)) *instruction-set*)))
@@ -128,32 +127,46 @@
;;; Execution
(define (jump addr)
(seek (current-input-port) addr SEEK_SET))
(define (tell)
(ftell (current-input-port)))
(define* (make-vm #:key stack-size memory-size)
"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))
(define (fetch-byte)
(let ([byte (ram-byte-ref pc)])
(set! pc (+ pc 1))
byte))
(define (fetch-word)
(let ([word (ram-word-ref pc)])
(set! pc (+ pc 4))
word))
(define (fetch-and-execute)
(define op (read-u8))
(unless (eof-object? op)
(define exit? #f)
(let lp ([op (fetch-byte)])
(case (op-lookup op)
[(push)
(push data-stack (read-word))]
[(pop)
(pop data-stack)]
[(store)
(let ([addr (read-word)]
(push data-stack (fetch-word))]
[(!)
(let ([addr (pop data-stack)]
[v (pop data-stack)])
(ram-set! ram addr v))]
[(load)
(let* ([addr (read-word)]
[v (ram-ref ram addr)])
(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)]
@@ -165,13 +178,15 @@
(if ((relop-lookup op) v1 v2)
(push data-stack 1)
(push data-stack 0)))]
[(if)
(let ([addr (read-word)])
(when (zero? (peek data-stack))
[(jmp)
(jump (pop data-stack))]
[(branch)
(let ([addr (pop data-stack)])
(when (zero? (pop data-stack))
(jump addr)))]
[(call)
(let ([addr (read-word)])
(push ret-stack (tell))
(let ([addr (pop data-stack)])
(push ret-stack pc)
(jump addr))]
[(return)
(jump (pop ret-stack))]
@@ -179,19 +194,41 @@
(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)]
[(jmp)
(jump (read-word))])
[(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))]
[(bye) (set! exit? #t)]))
(when (not exit?)
(fetch-and-execute)))
(lambda (x)
(case x
[(run) fetch-and-execute]
[(vm-run) fetch-and-execute]
[(vm-memory) (lambda () ram)]
[(vm-memory-ref) (cute ram-ref ram <>)]
[(vm-memory-set!) (lambda (k v) (ram-set! ram k v))])))
[(vm-memory-ref) ram-word-ref]
[(vm-memory-set!) ram-word-set!]
[(vm-pc-ref) (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"
@@ -205,6 +242,21 @@
"Just get the memory vector"
((vm 'vm-memory)))
(define (run-vm vm port)
"Read and execute instructions read from port on VM"
(with-input-from-port port (vm 'run)))
(define (vm-load-program! vm prgm)
"Loads the bytevector into the vm, starting at memory address 1"
(let ([ram ((vm 'vm-memory))])
(bytevector-copy! prgm 0
ram 0
(bytevector-length prgm))))
(define (vm-pc-ref vm)
"Return the value of the pc"
((vm 'vm-pc-ref)))
(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)))