315 lines
9.6 KiB
Scheme
315 lines
9.6 KiB
Scheme
(define-module (scmvm vm)
|
||
#:use-module ((scheme base)
|
||
#:select (read-u8 read-bytevector))
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (srfi srfi-43)
|
||
#:use-module (ice-9 format)
|
||
#:export (make-stack (push . stack-push) (pop . stack-pop) (peek . stack-peek) stack-ref stack->list
|
||
(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-instruction-set
|
||
instruction-lookup instruction-name instruction-code
|
||
forth-instruction-set))
|
||
|
||
;;; Data Structures
|
||
(define *stack-size* 512)
|
||
(define *memory-size* 2048)
|
||
|
||
(define* (make-stack #:optional (stack-size *stack-size*))
|
||
"Make a new stack, optionally setting the size"
|
||
(define the-stack (make-vector stack-size))
|
||
(define top 0)
|
||
(lambda (x)
|
||
(case x
|
||
[(push)
|
||
(lambda (v)
|
||
(if (>= top stack-size)
|
||
(error "stack overflow")
|
||
(begin
|
||
(vector-set! the-stack top v)
|
||
(set! top (1+ top)))))]
|
||
[(pop)
|
||
(lambda ()
|
||
(if (zero? top)
|
||
(error "pop empty stack")
|
||
(begin
|
||
(set! top (1- top))
|
||
(vector-ref the-stack top))))]
|
||
[(peek)
|
||
(lambda ()
|
||
(if (zero? top)
|
||
(error "peek empty stack")
|
||
(vector-ref the-stack (1- top))))]
|
||
[(swap)
|
||
(lambda ()
|
||
(if (< (vector-length the-stack) 2)
|
||
(error "no value to swap")
|
||
(let ([a (vector-ref the-stack (- top 2))]
|
||
[b (vector-ref the-stack (- top 1))])
|
||
(vector-set! the-stack (- top 2) b)
|
||
(vector-set! the-stack (- top 1) a))))]
|
||
[(ref)
|
||
(lambda (k)
|
||
(vector-ref the-stack k))]
|
||
[(->list)
|
||
(lambda ()
|
||
(reverse-vector->list the-stack 0 top))]
|
||
[(set!)
|
||
(lambda (k obj)
|
||
(vector-set! the-stack k obj))]
|
||
[else (error "stack dispatch unknown value")])))
|
||
|
||
(define (push stack v)
|
||
((stack 'push) v))
|
||
|
||
(define (pop stack)
|
||
((stack 'pop)))
|
||
|
||
(define (peek stack)
|
||
((stack 'peek)))
|
||
|
||
(define (swap stack)
|
||
((stack 'swap)))
|
||
|
||
(define (stack-ref stack k)
|
||
((stack 'ref) k))
|
||
|
||
(define* (make-ram #:optional (memory-size *memory-size*))
|
||
(make-bytevector memory-size #x00))
|
||
|
||
(define (stack->list stack)
|
||
((stack '->list)))
|
||
|
||
(define (stack-set! stack k obj)
|
||
((stack 'set!) k obj))
|
||
|
||
|
||
;;; IO
|
||
(define (read-word)
|
||
"Read the next 32-bit value from (current-input-port)"
|
||
(let ([bv (read-bytevector 4)])
|
||
(bytevector-s32-ref bv 0 (native-endianness))))
|
||
|
||
;;; Instructions
|
||
(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-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 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!)
|
||
(instruction-set vm-instruction-set vm-instruction-set-set!))
|
||
|
||
(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)))
|
||
(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"
|
||
(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)
|
||
(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)
|
||
(if (< k 1)
|
||
(error "null memory write")
|
||
(bytevector-s32-native-set! (vm-memory vm) (1- k) v)))
|
||
|
||
(define (vm-load-program! vm prgm)
|
||
"Loads the bytevector into the vm, starting at memory address 1"
|
||
(let ([ram (vm-memory vm)])
|
||
(bytevector-copy! prgm 0
|
||
ram 0
|
||
(bytevector-length prgm))))
|