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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
scmvm/assembler.scm
View File

@ -13,21 +13,22 @@
inst-obj inst-obj
(error (format #f "could not find instruction ~a" inst)))) (error (format #f "could not find instruction ~a" inst))))
(define (instruction-size inst) (define label? (compose not pair?))
(case (instruction-type (lookup-instruction inst)) (define (variable? x)
[(i j) 5] (and (pair? x) (eq? (car x) 'variable)))
[(o) 1])) (define (instruction? x)
(and (not (label? x))
(define instruction? pair?) (not (variable? x))))
(define label? (compose not instruction?))
(define (find-labels inst-seq n) (define (find-labels inst-seq n)
(cond (cond
[(null? inst-seq) '()] [(null? inst-seq) '()]
[(label? (car inst-seq)) [(label? (car inst-seq))
(acons (car inst-seq) n (find-labels (cdr inst-seq) n))] (acons (car inst-seq) n (find-labels (cdr inst-seq) n))]
[(variable? (car inst-seq))
(acons (cadar inst-seq) n (find-labels (cdr inst-seq) (+ n 4)))]
[else [else
(find-labels (cdr inst-seq) (+ n (instruction-size (caar inst-seq))))])) (find-labels (cdr inst-seq) (if (eq? (caar inst-seq) 'push) (+ n 5) (+ n 1)))]))
(define (write-word word) (define (write-word word)
(define bv (make-bytevector 4)) (define bv (make-bytevector 4))
@ -37,16 +38,20 @@
(define (assemble inst-seq port) (define (assemble inst-seq port)
(with-output-to-port port (with-output-to-port port
(lambda () (lambda ()
(define labels (find-labels inst-seq 0)) (define labels (find-labels inst-seq 1))
(let loop ([seq inst-seq]) (let loop ([seq inst-seq])
(cond (cond
[(null? seq) '()] [(null? seq) '()]
[(label? (car seq)) (loop (cdr seq))] [(label? (car seq)) (loop (cdr seq))]
[(variable? (car seq))
(write-word (caddar seq))
(loop (cdr seq))]
[else [else
(let* [(inst (car seq)) (let* [(inst (car seq))
(inst-obj (lookup-instruction (car inst)))] (inst-obj (lookup-instruction (car inst)))]
(write-u8 (instruction-code inst-obj)) (write-u8 (instruction-code inst-obj))
(case (instruction-type inst-obj) (when (eq? (car inst) 'push)
[(i) (write-word (cadr inst))] (if (number? (cadr inst))
[(j) (write-word (assq-ref labels (cadr inst)))]) (write-word (cadr inst))
(write-word (assq-ref labels (cadr inst)))))
(loop (cdr seq)))]))))) (loop (cdr seq)))])))))

172
scmvm/vm.scm
View File

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

140
tests.scm
View File

@ -8,93 +8,101 @@
;;; Data ;;; Data
(define adder-program-asm (define adder-program-asm
'((push 1) '((variable result 0)
(push 1)
(push 2) (push 2)
(+) (+)
(store #x01))) (push result)
(!)
(bye)))
(define fib-program-asm (define fib-program-asm
'( (load 1) '( (variable result 0)
(call fib) (push result)
(jmp cleanup) (@)
(push fib)
(call)
(push cleanup)
(jmp)
fib fib
(dup) (dup)
(push 0) (push 0)
(=) (=)
(if not0) (over)
(pop)
(pop)
(push 0)
(return)
not0
(pop)
(dup)
(push 1) (push 1)
(=) (=)
(if not1) (or)
(pop) (push recur)
(pop) (branch)
(push 1)
(return) (return)
not1 recur
(pop)
(push 1)
(-)
(dup) (dup)
(call fib)
(swap)
(push 1) (push 1)
(-) (-)
(call fib) (push fib)
(call)
(over)
(push 2)
(-)
(push fib)
(call)
(+) (+)
(nip)
(return) (return)
cleanup cleanup
(store #x1))) (push result)
(!)
(bye)))
(define adder-program-bytecode (define adder-program-bytecode
#vu8(#x01 1 0 0 0 ; Push value "1" #vu8(0 0 0 0 ; Memory address of the result
#x01 1 0 0 0 ; Push value "1"
#x01 2 0 0 0 ; Push value "2" #x01 2 0 0 0 ; Push value "2"
#x05 ; Perform "+" #x04 ; Perform "+"
#x03 1 0 0 0 ; Store the value to memory address 1 #x01 1 0 0 0 ; Push the address of the result
#x02 ; Store the value
#xff ; Exit the program
)) ))
(define fib-program-bytecode (define fib-program-bytecode
#vu8(#x04 1 0 0 0 ; 0 load "n" from memory address 0x01 #vu8(0 0 0 0 ; Memory address of the input, will also store the result
#x0d 15 0 0 0 ; 5 call fib procedure #x1 1 0 0 0 ; Push address of the input
#x16 83 0 0 0 ; 10 jump to cleanup #x03 ; Fetch "n"
;; "fib" procedure #x1 23 0 0 0 ; Push address of "fib"
#x14 ; 15 duplicate n #x10 ; Call
#x01 0 0 0 0 ; 16 push 0 #x01 74 0 0 0 ; Push address of "cleanup"
#x11 ; 21 test equality #x0e ; Jump
#x0c 35 0 0 0 ; 22 if ;; "fib" procedure ( n -- fib(n) )
#x02 ; 27 pop tested value #x16 ; Duplicate n
#x02 ; 28 pop n #x01 0 0 0 0 ; Push 0
#x01 0 0 0 0 ; 29 push '0' #x0b ; Test equality
#x0e ; 31 return #x19 ; Over
#x02 ; 35 pop tested value #x01 1 0 0 0 ; Push 1
#x14 ; 36 duplicate n #x0b ; Test equality
#x01 1 0 0 0 ; 37 push 1 #x07 ; OR the values of the last two tests
#x11 ; 42 test equality #x01 45 0 0 0 ; Push address of "recur"
#x0c 56 0 0 0 ; 43 if #x0f ; Branch
#x02 ; 48 pop tested value #x11 ; Return
#x02 ; 49 pop n ;; "recur" label
#x01 1 0 0 0 ; 50 push '1'
#x0e ; 55 return
#x02 ; 56 pop tested value
;; recursively calculate fib (n - 1) ;; recursively calculate fib (n - 1)
#x01 1 0 0 0 ; 57 push 1 #x16 ; Dupe "n"
#x06 ; 62 (n - 1) #x01 1 0 0 0 ; Push 1
#x14 ; 63 duplicate (n - 1) as an arg #x05 ; (n - 1)
#x0d 15 0 0 0 ; 64 call fib #x01 23 0 0 0 ; Push address of "fib"
#x10 ; Call
;; recursively calculate fib (n - 2) ;; recursively calculate fib (n - 2)
#x15 ; 69 swap n - 1 back atop stack #x19 ; Dupe n over the result
#x01 1 0 0 0 ; 70 push 1 #x01 2 0 0 0 ; Push 2
#x06 ; 75 (n - 2) #x05 ; (n - 2)
#x0d 15 0 0 0 ; 76 call fib #x01 23 0 0 0 ; Push address of fib
#x05 ; 81 (fib(n - 1) + fib (n - 2)) #x10 ; Call
#x0e ; 82 return #x04 ; (fib(n - 1) + fib (n - 2))
#x15 ; Nip the dupe of "n"
#x11 ; Return
;; cleanup ;; cleanup
#x03 1 0 0 0 ; 83 store fib(n) to memory address 0x01 #x01 1 0 0 0 ; Push memory address of result
#x02 ; Store fib(n)
#xff ; Exit program
)) ))
@ -112,12 +120,14 @@
(define-test-suite "vm" (define-test-suite "vm"
(define-test "adder" (define-test "adder"
(define my-vm (make-vm)) (define my-vm (make-vm))
(define my-program (open-bytevector-input-port adder-program-bytecode)) (vm-load-program! my-vm adder-program-bytecode)
(run-vm my-vm my-program) (vm-pc-set! my-vm 5)
((my-vm 'vm-run))
(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-memory-set! my-vm 1 10) (vm-memory-set! my-vm 1 10)
(define my-program (open-bytevector-input-port fib-program-bytecode)) (vm-pc-set! my-vm 5)
(run-vm my-vm my-program) ((my-vm 'vm-run))
(assert-equal 55 (vm-memory-ref my-vm 1)))) (assert-equal 55 (vm-memory-ref my-vm 1))))