All is one-op instructions (save push). Code in memory (this will allow compilation)
This commit is contained in:
parent
11eae06995
commit
679b53d76e
@ -13,21 +13,22 @@
|
||||
inst-obj
|
||||
(error (format #f "could not find instruction ~a" inst))))
|
||||
|
||||
(define (instruction-size inst)
|
||||
(case (instruction-type (lookup-instruction inst))
|
||||
[(i j) 5]
|
||||
[(o) 1]))
|
||||
|
||||
(define instruction? pair?)
|
||||
(define label? (compose not instruction?))
|
||||
(define label? (compose not pair?))
|
||||
(define (variable? x)
|
||||
(and (pair? x) (eq? (car x) 'variable)))
|
||||
(define (instruction? x)
|
||||
(and (not (label? x))
|
||||
(not (variable? x))))
|
||||
|
||||
(define (find-labels inst-seq n)
|
||||
(cond
|
||||
[(null? inst-seq) '()]
|
||||
[(label? (car inst-seq))
|
||||
(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
|
||||
(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 bv (make-bytevector 4))
|
||||
@ -37,16 +38,20 @@
|
||||
(define (assemble inst-seq port)
|
||||
(with-output-to-port port
|
||||
(lambda ()
|
||||
(define labels (find-labels inst-seq 0))
|
||||
(define labels (find-labels inst-seq 1))
|
||||
(let loop ([seq inst-seq])
|
||||
(cond
|
||||
[(null? seq) '()]
|
||||
[(label? (car seq)) (loop (cdr seq))]
|
||||
[(variable? (car seq))
|
||||
(write-word (caddar seq))
|
||||
(loop (cdr seq))]
|
||||
[else
|
||||
(let* [(inst (car seq))
|
||||
(inst-obj (lookup-instruction (car inst)))]
|
||||
(write-u8 (instruction-code inst-obj))
|
||||
(case (instruction-type inst-obj)
|
||||
[(i) (write-word (cadr inst))]
|
||||
[(j) (write-word (assq-ref labels (cadr inst)))])
|
||||
(when (eq? (car inst) 'push)
|
||||
(if (number? (cadr inst))
|
||||
(write-word (cadr inst))
|
||||
(write-word (assq-ref labels (cadr inst)))))
|
||||
(loop (cdr seq)))])))))
|
||||
|
||||
172
scmvm/vm.scm
172
scmvm/vm.scm
@ -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)))
|
||||
|
||||
140
tests.scm
140
tests.scm
@ -8,93 +8,101 @@
|
||||
|
||||
;;; Data
|
||||
(define adder-program-asm
|
||||
'((push 1)
|
||||
'((variable result 0)
|
||||
(push 1)
|
||||
(push 2)
|
||||
(+)
|
||||
(store #x01)))
|
||||
(push result)
|
||||
(!)
|
||||
(bye)))
|
||||
|
||||
(define fib-program-asm
|
||||
'( (load 1)
|
||||
(call fib)
|
||||
(jmp cleanup)
|
||||
'( (variable result 0)
|
||||
(push result)
|
||||
(@)
|
||||
(push fib)
|
||||
(call)
|
||||
(push cleanup)
|
||||
(jmp)
|
||||
fib
|
||||
(dup)
|
||||
(push 0)
|
||||
(=)
|
||||
(if not0)
|
||||
(pop)
|
||||
(pop)
|
||||
(push 0)
|
||||
(return)
|
||||
not0
|
||||
(pop)
|
||||
(dup)
|
||||
(over)
|
||||
(push 1)
|
||||
(=)
|
||||
(if not1)
|
||||
(pop)
|
||||
(pop)
|
||||
(push 1)
|
||||
(or)
|
||||
(push recur)
|
||||
(branch)
|
||||
(return)
|
||||
not1
|
||||
(pop)
|
||||
(push 1)
|
||||
(-)
|
||||
recur
|
||||
(dup)
|
||||
(call fib)
|
||||
(swap)
|
||||
(push 1)
|
||||
(-)
|
||||
(call fib)
|
||||
(push fib)
|
||||
(call)
|
||||
(over)
|
||||
(push 2)
|
||||
(-)
|
||||
(push fib)
|
||||
(call)
|
||||
(+)
|
||||
(nip)
|
||||
(return)
|
||||
cleanup
|
||||
(store #x1)))
|
||||
(push result)
|
||||
(!)
|
||||
(bye)))
|
||||
|
||||
(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"
|
||||
#x05 ; Perform "+"
|
||||
#x03 1 0 0 0 ; Store the value to memory address 1
|
||||
#x04 ; Perform "+"
|
||||
#x01 1 0 0 0 ; Push the address of the result
|
||||
#x02 ; Store the value
|
||||
#xff ; Exit the program
|
||||
))
|
||||
|
||||
(define fib-program-bytecode
|
||||
#vu8(#x04 1 0 0 0 ; 0 load "n" from memory address 0x01
|
||||
#x0d 15 0 0 0 ; 5 call fib procedure
|
||||
#x16 83 0 0 0 ; 10 jump to cleanup
|
||||
;; "fib" procedure
|
||||
#x14 ; 15 duplicate n
|
||||
#x01 0 0 0 0 ; 16 push 0
|
||||
#x11 ; 21 test equality
|
||||
#x0c 35 0 0 0 ; 22 if
|
||||
#x02 ; 27 pop tested value
|
||||
#x02 ; 28 pop n
|
||||
#x01 0 0 0 0 ; 29 push '0'
|
||||
#x0e ; 31 return
|
||||
#x02 ; 35 pop tested value
|
||||
#x14 ; 36 duplicate n
|
||||
#x01 1 0 0 0 ; 37 push 1
|
||||
#x11 ; 42 test equality
|
||||
#x0c 56 0 0 0 ; 43 if
|
||||
#x02 ; 48 pop tested value
|
||||
#x02 ; 49 pop n
|
||||
#x01 1 0 0 0 ; 50 push '1'
|
||||
#x0e ; 55 return
|
||||
#x02 ; 56 pop tested value
|
||||
#vu8(0 0 0 0 ; Memory address of the input, will also store the result
|
||||
#x1 1 0 0 0 ; Push address of the input
|
||||
#x03 ; Fetch "n"
|
||||
#x1 23 0 0 0 ; Push address of "fib"
|
||||
#x10 ; Call
|
||||
#x01 74 0 0 0 ; Push address of "cleanup"
|
||||
#x0e ; Jump
|
||||
;; "fib" procedure ( n -- fib(n) )
|
||||
#x16 ; Duplicate n
|
||||
#x01 0 0 0 0 ; Push 0
|
||||
#x0b ; Test equality
|
||||
#x19 ; Over
|
||||
#x01 1 0 0 0 ; Push 1
|
||||
#x0b ; Test equality
|
||||
#x07 ; OR the values of the last two tests
|
||||
#x01 45 0 0 0 ; Push address of "recur"
|
||||
#x0f ; Branch
|
||||
#x11 ; Return
|
||||
;; "recur" label
|
||||
;; recursively calculate fib (n - 1)
|
||||
#x01 1 0 0 0 ; 57 push 1
|
||||
#x06 ; 62 (n - 1)
|
||||
#x14 ; 63 duplicate (n - 1) as an arg
|
||||
#x0d 15 0 0 0 ; 64 call fib
|
||||
#x16 ; Dupe "n"
|
||||
#x01 1 0 0 0 ; Push 1
|
||||
#x05 ; (n - 1)
|
||||
#x01 23 0 0 0 ; Push address of "fib"
|
||||
#x10 ; Call
|
||||
;; recursively calculate fib (n - 2)
|
||||
#x15 ; 69 swap n - 1 back atop stack
|
||||
#x01 1 0 0 0 ; 70 push 1
|
||||
#x06 ; 75 (n - 2)
|
||||
#x0d 15 0 0 0 ; 76 call fib
|
||||
#x05 ; 81 (fib(n - 1) + fib (n - 2))
|
||||
#x0e ; 82 return
|
||||
#x19 ; Dupe n over the result
|
||||
#x01 2 0 0 0 ; Push 2
|
||||
#x05 ; (n - 2)
|
||||
#x01 23 0 0 0 ; Push address of fib
|
||||
#x10 ; Call
|
||||
#x04 ; (fib(n - 1) + fib (n - 2))
|
||||
#x15 ; Nip the dupe of "n"
|
||||
#x11 ; Return
|
||||
;; 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 "adder"
|
||||
(define my-vm (make-vm))
|
||||
(define my-program (open-bytevector-input-port adder-program-bytecode))
|
||||
(run-vm my-vm my-program)
|
||||
(vm-load-program! my-vm adder-program-bytecode)
|
||||
(vm-pc-set! my-vm 5)
|
||||
((my-vm 'vm-run))
|
||||
(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)
|
||||
(define my-program (open-bytevector-input-port fib-program-bytecode))
|
||||
(run-vm my-vm my-program)
|
||||
(vm-pc-set! my-vm 5)
|
||||
((my-vm 'vm-run))
|
||||
(assert-equal 55 (vm-memory-ref my-vm 1))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user