Compare commits
3 Commits
0783e7c587
...
master
| Author | SHA1 | Date | |
|---|---|---|---|
| 51e34c9750 | |||
| b50d3109c0 | |||
| d44f5d2851 |
@@ -1,13 +1,14 @@
|
|||||||
(define-module (scmvm debugger)
|
(define-module (scmvm debugger)
|
||||||
#:use-module (scmvm assembler)
|
#:use-module (scmvm assembler)
|
||||||
#:use-module (scmvm vm)
|
#:use-module (scmvm vm)
|
||||||
|
#:use-module (scmvm vm forth)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (ice-9 control)
|
#:use-module (ice-9 control)
|
||||||
#:use-module (ice-9 binary-ports)
|
#:use-module (ice-9 binary-ports)
|
||||||
#:use-module (ice-9 exceptions)
|
#:use-module (ice-9 exceptions)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:export ((make-debugger* . make-debugger) debugger-vm debugger-source
|
#:export (make-forth-debugger debugger-vm debugger-source
|
||||||
debugger-breakpoints debugger-breakpoints-set!
|
debugger-breakpoints debugger-breakpoints-set!
|
||||||
debugger-breakpoint-add! debugger-breakpoint-ref
|
debugger-breakpoint-add! debugger-breakpoint-ref
|
||||||
debugger-breakpoint-enable! debugger-breakpoint-disable!
|
debugger-breakpoint-enable! debugger-breakpoint-disable!
|
||||||
@@ -37,7 +38,7 @@
|
|||||||
index/label
|
index/label
|
||||||
(car (hash-ref (assembler-labels asm) index/label)))))
|
(car (hash-ref (assembler-labels asm) index/label)))))
|
||||||
|
|
||||||
(define (make-debugger* asm)
|
(define (make-forth-debugger asm)
|
||||||
(define prgm
|
(define prgm
|
||||||
(call-with-values open-bytevector-output-port
|
(call-with-values open-bytevector-output-port
|
||||||
(lambda (port get-bv)
|
(lambda (port get-bv)
|
||||||
@@ -47,14 +48,14 @@
|
|||||||
(define (debug)
|
(define (debug)
|
||||||
(shift k
|
(shift k
|
||||||
(if (or (debugger-stepping? the-debugger)
|
(if (or (debugger-stepping? the-debugger)
|
||||||
(((debugger-breakpoints the-debugger) 'ref) (vm-pc (debugger-vm the-debugger))))
|
(((debugger-breakpoints the-debugger) 'ref) (forth-vm-pc (debugger-vm the-debugger))))
|
||||||
(debugger-continuation-set! the-debugger k)
|
(debugger-continuation-set! the-debugger k)
|
||||||
(k))))
|
(k))))
|
||||||
(define vm (make-vm (assembler-instruction-set asm) #:debugger debug))
|
(define vm (make-forth-vm (assembler-instruction-set asm)))
|
||||||
(vm-load-program! vm prgm)
|
(forth-vm-load-program! vm prgm)
|
||||||
(set! the-debugger (make-debugger vm asm (make-breakpoints (label-converter asm)) #f #f))
|
(set! the-debugger (make-debugger vm asm (make-breakpoints (label-converter asm)) #f #f))
|
||||||
(debugger-breakpoint-add! the-debugger 1)
|
(debugger-breakpoint-add! the-debugger 1)
|
||||||
(reset (run-vm vm))
|
(reset (forth-vm-run! vm debug))
|
||||||
the-debugger)
|
the-debugger)
|
||||||
|
|
||||||
(define (debugger-continue debugger)
|
(define (debugger-continue debugger)
|
||||||
|
|||||||
@@ -1,7 +1,8 @@
|
|||||||
(define-module (scmvm util stack)
|
(define-module (scmvm util stack)
|
||||||
#:use-module (srfi srfi-43)
|
#:use-module (srfi srfi-43)
|
||||||
#:export (make-stack stack-ref stack->list stack-set!
|
#:replace (make-stack)
|
||||||
(push . stack-push) (pop . stack-pop) (peek . stack-peek) (swap . stack-swap)))
|
#:export (stack-ref stack->list stack-set!
|
||||||
|
(push . stack-push) (pop . stack-pop) (peek . stack-peek) (swap . stack-swap)))
|
||||||
|
|
||||||
;; Stack data structure. I made this a closure implementation for some reason
|
;; Stack data structure. I made this a closure implementation for some reason
|
||||||
|
|
||||||
|
|||||||
243
scmvm/vm.scm
243
scmvm/vm.scm
@@ -1,37 +1,16 @@
|
|||||||
(define-module (scmvm vm)
|
(define-module (scmvm vm)
|
||||||
#:use-module ((scheme base)
|
#:use-module (ice-9 hash-table)
|
||||||
#:select (read-u8 read-bytevector))
|
#:export (define-instruction-set
|
||||||
#:use-module (rnrs bytevectors)
|
instruction-lookup
|
||||||
#:use-module (srfi srfi-1)
|
instruction-set-caller
|
||||||
#:use-module (srfi srfi-9)
|
instruction-name
|
||||||
#:use-module (srfi srfi-26)
|
instruction-code
|
||||||
#:use-module (srfi srfi-43)
|
register-set))
|
||||||
#:use-module (ice-9 format)
|
|
||||||
#:use-module (scmvm util stack)
|
|
||||||
#:export ((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))
|
|
||||||
|
|
||||||
;;; IO
|
|
||||||
(define *memory-size* 2048)
|
|
||||||
|
|
||||||
(define* (make-ram #:optional (memory-size *memory-size*))
|
|
||||||
(make-bytevector memory-size #x00))
|
|
||||||
|
|
||||||
(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
|
;;; Instructions
|
||||||
(define-syntax define-instruction-set
|
(define-syntax define-instruction-set
|
||||||
(syntax-rules (define-instruction)
|
(syntax-rules (define-instruction)
|
||||||
[(_ set-name (define-instruction (name opcode) impl ...) ...)
|
[(_ (set-name reg ...) (define-instruction (name opcode) impl ...) ...)
|
||||||
(define (set-name dispatch)
|
(define (set-name dispatch)
|
||||||
(case dispatch
|
(case dispatch
|
||||||
[(lookup)
|
[(lookup)
|
||||||
@@ -40,207 +19,21 @@
|
|||||||
[(name) '(name opcode)] ...
|
[(name) '(name opcode)] ...
|
||||||
[else #f]))]
|
[else #f]))]
|
||||||
[(call)
|
[(call)
|
||||||
(lambda (op)
|
(lambda (registers)
|
||||||
(case op
|
(let ([reg (hash-ref registers 'reg)] ...)
|
||||||
[(opcode) impl ...] ...))]))]))
|
(parameterize ([reg #f] ...)
|
||||||
|
(lambda (op)
|
||||||
|
(case op
|
||||||
|
[(opcode) impl ...] ...)))))]))]))
|
||||||
|
|
||||||
(define (instruction-lookup isa name)
|
(define (instruction-lookup isa name)
|
||||||
((isa 'lookup) name))
|
((isa 'lookup) name))
|
||||||
|
|
||||||
(define (instruction-set-call isa op)
|
(define (instruction-set-caller instruction-set registers)
|
||||||
((isa 'call) op))
|
((instruction-set 'call) registers))
|
||||||
|
|
||||||
(define instruction-name car)
|
(define instruction-name car)
|
||||||
(define instruction-code cadr)
|
(define instruction-code cadr)
|
||||||
|
|
||||||
(define-instruction-set forth-instruction-set
|
(define (register-set names)
|
||||||
(define-instruction (push #x01)
|
(alist->hash-table (map (lambda (n) (cons n (make-parameter #f))) names)))
|
||||||
(stack-push (*data-stack*) (fetch-word!)))
|
|
||||||
(define-instruction (! #x02)
|
|
||||||
(let ([addr (stack-pop (*data-stack*))]
|
|
||||||
[v (stack-pop (*data-stack*))])
|
|
||||||
(ram-word-set! addr v)))
|
|
||||||
(define-instruction (@ #x03)
|
|
||||||
(let* ([addr (stack-pop (*data-stack*))]
|
|
||||||
[v (ram-word-ref addr)])
|
|
||||||
(stack-push (*data-stack*) v)))
|
|
||||||
(define-instruction (+ #x04)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (+ v1 v2))))
|
|
||||||
(define-instruction (- #x05)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (- v1 v2))))
|
|
||||||
(define-instruction (and #x06)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (logand v1 v2))))
|
|
||||||
(define-instruction (or #x07)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (logior v1 v2))))
|
|
||||||
(define-instruction (nand #x08)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (if (zero? (logand v1 v2)) 1 0))))
|
|
||||||
(define-instruction (nor #x09)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (if (zero? (logior v1 v2)) 1 0))))
|
|
||||||
(define-instruction (xor #x0a)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (logxor v1 v2))))
|
|
||||||
(define-instruction (= #x0b)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(if (= v1 v2)
|
|
||||||
(stack-push (*data-stack*) 1)
|
|
||||||
(stack-push (*data-stack*) 0))))
|
|
||||||
(define-instruction (> #x0c)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(if (> v1 v2)
|
|
||||||
(stack-push (*data-stack*) 1)
|
|
||||||
(stack-push (*data-stack*) 0))))
|
|
||||||
(define-instruction (< #x0d)
|
|
||||||
(let ([v2 (stack-pop (*data-stack*))]
|
|
||||||
[v1 (stack-pop (*data-stack*))])
|
|
||||||
(if (< v1 v2)
|
|
||||||
(stack-push (*data-stack*) 1)
|
|
||||||
(stack-push (*data-stack*) 0))))
|
|
||||||
(define-instruction (jmp #x0e)
|
|
||||||
(jump! (stack-pop (*data-stack*))))
|
|
||||||
(define-instruction (branch #x0f)
|
|
||||||
(let* ([addr (stack-pop (*data-stack*))]
|
|
||||||
[test (stack-pop (*data-stack*))])
|
|
||||||
(when (zero? test)
|
|
||||||
(jump! addr))))
|
|
||||||
(define-instruction (call #x10)
|
|
||||||
(let ([addr (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*ret-stack*) (vm-pc (*vm*)))
|
|
||||||
(jump! addr)))
|
|
||||||
(define-instruction (return #x11)
|
|
||||||
(jump! (stack-pop (*ret-stack*))))
|
|
||||||
(define-instruction (>R #x12)
|
|
||||||
(stack-push (*ret-stack*) (stack-pop (*data-stack*))))
|
|
||||||
(define-instruction (R> #x13)
|
|
||||||
(stack-push (*data-stack*) (stack-pop (*ret-stack*))))
|
|
||||||
(define-instruction (drop #x14)
|
|
||||||
(stack-pop (*data-stack*)))
|
|
||||||
(define-instruction (nip #x15)
|
|
||||||
(let ([v (stack-pop (*data-stack*))])
|
|
||||||
(stack-pop (*data-stack*))
|
|
||||||
(stack-push (*data-stack*) v)))
|
|
||||||
(define-instruction (dup #x16)
|
|
||||||
(stack-push (*data-stack*) (stack-peek (*data-stack*))))
|
|
||||||
(define-instruction (swap #x17)
|
|
||||||
(stack-swap (*data-stack*)))
|
|
||||||
(define-instruction (rot #x18)
|
|
||||||
(let* ([a (stack-pop (*data-stack*))]
|
|
||||||
[b (stack-pop (*data-stack*))]
|
|
||||||
[c (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) a)
|
|
||||||
(stack-push (*data-stack*) c)
|
|
||||||
(stack-push (*data-stack*) b)))
|
|
||||||
(define-instruction (over #x19)
|
|
||||||
(let* ([a (stack-pop (*data-stack*))]
|
|
||||||
[b (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) b)
|
|
||||||
(stack-push (*data-stack*) a)
|
|
||||||
(stack-push (*data-stack*) b)))
|
|
||||||
(define-instruction (not #x1a)
|
|
||||||
(let ([a (stack-pop (*data-stack*))])
|
|
||||||
(stack-push (*data-stack*) (if (zero? a) 1 0))))
|
|
||||||
(define-instruction (set! #x1b)
|
|
||||||
;; use let* to induce an order of evaluation
|
|
||||||
(let* ([idx (stack-pop (*data-stack*))]
|
|
||||||
[obj (stack-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))))
|
|
||||||
|
|||||||
279
scmvm/vm/forth.scm
Normal file
279
scmvm/vm/forth.scm
Normal file
@@ -0,0 +1,279 @@
|
|||||||
|
(define-module (scmvm vm forth)
|
||||||
|
#:use-module (scmvm vm)
|
||||||
|
#:use-module (scmvm util stack)
|
||||||
|
#:use-module ((scheme base)
|
||||||
|
#:select (read-u8 read-bytevector))
|
||||||
|
#:use-module (rnrs bytevectors)
|
||||||
|
#:use-module (srfi srfi-9)
|
||||||
|
#:export ((make-forth-vm* . make-forth-vm)
|
||||||
|
forth-instruction-set
|
||||||
|
forth-vm-load-program!
|
||||||
|
forth-vm-run!
|
||||||
|
forth-vm-pc
|
||||||
|
forth-vm-pc-set!
|
||||||
|
forth-vm-memory-set!
|
||||||
|
forth-vm-memory-ref
|
||||||
|
forth-vm-data-stack))
|
||||||
|
|
||||||
|
;;; IO
|
||||||
|
(define *memory-size* 2048)
|
||||||
|
|
||||||
|
(define* (make-ram #:optional (memory-size *memory-size*))
|
||||||
|
(make-bytevector memory-size #x00))
|
||||||
|
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
|
||||||
|
;;; VM
|
||||||
|
(define-record-type <forth-vm>
|
||||||
|
(make-forth-vm instruction-set registers)
|
||||||
|
forth-vm?
|
||||||
|
(instruction-set forth-vm-instruction-set)
|
||||||
|
(registers forth-vm-registers forth-vm-registers-set!))
|
||||||
|
|
||||||
|
(define* (make-forth-vm* instruction-set #:key stack-size memory-size)
|
||||||
|
"Create a fresh VM, with optional stack and memory sizes"
|
||||||
|
(define registers (register-set '(*data-stack* *ret-stack* *pc* *ram* *vm-exit*)))
|
||||||
|
((hash-ref registers '*pc*) 1)
|
||||||
|
((hash-ref registers '*data-stack*) (if stack-size (make-stack stack-size) (make-stack)))
|
||||||
|
((hash-ref registers '*ret-stack*) (if stack-size (make-stack stack-size) (make-stack)))
|
||||||
|
((hash-ref registers '*ram*) (if memory-size (make-ram memory-size) (make-ram)))
|
||||||
|
(make-forth-vm instruction-set registers))
|
||||||
|
|
||||||
|
(define *vm* (make-parameter #f))
|
||||||
|
|
||||||
|
(define-syntax-rule (with-forth-vm-registers (reg ...) expr ...)
|
||||||
|
(let ([reg (hash-ref (forth-vm-registers (*vm*)) 'reg)] ...)
|
||||||
|
expr ...))
|
||||||
|
|
||||||
|
(define (ram-word-ref k)
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*ram*)
|
||||||
|
(if (< k 1)
|
||||||
|
(error "null memory read")
|
||||||
|
(bytevector-s32-native-ref (*ram*) (1- k)))))
|
||||||
|
|
||||||
|
(define (ram-byte-ref k)
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*ram*)
|
||||||
|
(if (< k 1)
|
||||||
|
(error "null memory read")
|
||||||
|
(bytevector-u8-ref (*ram*) (1- k)))))
|
||||||
|
|
||||||
|
(define (ram-word-set! k v)
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*ram*)
|
||||||
|
(if (< k 1)
|
||||||
|
(error "null memory write")
|
||||||
|
(bytevector-s32-native-set! (*ram*) (1- k) v))))
|
||||||
|
|
||||||
|
(define (jump! x)
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*pc*)
|
||||||
|
(*pc* (logand #x2fffffff x))))
|
||||||
|
|
||||||
|
(define (fetch-byte!)
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*pc*)
|
||||||
|
(let* ([byte (ram-byte-ref (*pc*))])
|
||||||
|
(*pc* (+ (*pc*) 1))
|
||||||
|
byte)))
|
||||||
|
|
||||||
|
(define (fetch-word!)
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*ram* *pc*)
|
||||||
|
(let* ([word (ram-word-ref (*pc*))])
|
||||||
|
(*pc* (+ (*pc*) 4))
|
||||||
|
word)))
|
||||||
|
|
||||||
|
(define (forth-vm-pc vm)
|
||||||
|
(parameterize ([*vm* vm])
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*pc*)
|
||||||
|
(*pc*))))
|
||||||
|
|
||||||
|
(define (forth-vm-pc-set! vm k)
|
||||||
|
(parameterize ([*vm* vm])
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*pc*)
|
||||||
|
(*pc* k))))
|
||||||
|
|
||||||
|
(define (forth-vm-memory-set! vm k v)
|
||||||
|
(parameterize ([*vm* vm])
|
||||||
|
(ram-word-set! k v)))
|
||||||
|
|
||||||
|
(define (forth-vm-memory-ref vm k)
|
||||||
|
(parameterize ([*vm* vm])
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*ram*)
|
||||||
|
(ram-word-ref k))))
|
||||||
|
|
||||||
|
(define (forth-vm-data-stack vm)
|
||||||
|
(parameterize ([*vm* vm])
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*data-stack*)
|
||||||
|
(*data-stack*))))
|
||||||
|
|
||||||
|
;;; Instruction set
|
||||||
|
(define-instruction-set (forth-instruction-set *pc* *ram* *data-stack* *ret-stack* *vm-exit*)
|
||||||
|
(define-instruction (push #x01)
|
||||||
|
(stack-push (*data-stack*) (fetch-word!)))
|
||||||
|
|
||||||
|
(define-instruction (! #x02)
|
||||||
|
(let ([addr (stack-pop (*data-stack*))]
|
||||||
|
[v (stack-pop (*data-stack*))])
|
||||||
|
(ram-word-set! addr v)))
|
||||||
|
|
||||||
|
(define-instruction (@ #x03)
|
||||||
|
(let* ([addr (stack-pop (*data-stack*))]
|
||||||
|
[v (ram-word-ref addr)])
|
||||||
|
(stack-push (*data-stack*) v)))
|
||||||
|
|
||||||
|
(define-instruction (+ #x04)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (+ v1 v2))))
|
||||||
|
|
||||||
|
(define-instruction (- #x05)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (- v1 v2))))
|
||||||
|
|
||||||
|
(define-instruction (and #x06)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (logand v1 v2))))
|
||||||
|
|
||||||
|
(define-instruction (or #x07)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (logior v1 v2))))
|
||||||
|
|
||||||
|
(define-instruction (nand #x08)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (if (zero? (logand v1 v2)) 1 0))))
|
||||||
|
|
||||||
|
(define-instruction (nor #x09)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (if (zero? (logior v1 v2)) 1 0))))
|
||||||
|
|
||||||
|
(define-instruction (xor #x0a)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (logxor v1 v2))))
|
||||||
|
|
||||||
|
(define-instruction (= #x0b)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(if (= v1 v2)
|
||||||
|
(stack-push (*data-stack*) 1)
|
||||||
|
(stack-push (*data-stack*) 0))))
|
||||||
|
|
||||||
|
(define-instruction (> #x0c)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(if (> v1 v2)
|
||||||
|
(stack-push (*data-stack*) 1)
|
||||||
|
(stack-push (*data-stack*) 0))))
|
||||||
|
|
||||||
|
(define-instruction (< #x0d)
|
||||||
|
(let ([v2 (stack-pop (*data-stack*))]
|
||||||
|
[v1 (stack-pop (*data-stack*))])
|
||||||
|
(if (< v1 v2)
|
||||||
|
(stack-push (*data-stack*) 1)
|
||||||
|
(stack-push (*data-stack*) 0))))
|
||||||
|
|
||||||
|
(define-instruction (jmp #x0e)
|
||||||
|
(jump! (stack-pop (*data-stack*))))
|
||||||
|
|
||||||
|
(define-instruction (branch #x0f)
|
||||||
|
(let* ([addr (stack-pop (*data-stack*))]
|
||||||
|
[test (stack-pop (*data-stack*))])
|
||||||
|
(when (zero? test)
|
||||||
|
(jump! addr))))
|
||||||
|
|
||||||
|
(define-instruction (call #x10)
|
||||||
|
(let ([addr (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*ret-stack*) (*pc*))
|
||||||
|
(jump! addr)))
|
||||||
|
|
||||||
|
(define-instruction (return #x11)
|
||||||
|
(jump! (stack-pop (*ret-stack*))))
|
||||||
|
|
||||||
|
(define-instruction (>R #x12)
|
||||||
|
(stack-push (*ret-stack*) (stack-pop (*data-stack*))))
|
||||||
|
|
||||||
|
(define-instruction (R> #x13)
|
||||||
|
(stack-push (*data-stack*) (stack-pop (*ret-stack*))))
|
||||||
|
|
||||||
|
(define-instruction (drop #x14)
|
||||||
|
(stack-pop (*data-stack*)))
|
||||||
|
|
||||||
|
(define-instruction (nip #x15)
|
||||||
|
(let ([v (stack-pop (*data-stack*))])
|
||||||
|
(stack-pop (*data-stack*))
|
||||||
|
(stack-push (*data-stack*) v)))
|
||||||
|
|
||||||
|
(define-instruction (dup #x16)
|
||||||
|
(stack-push (*data-stack*) (stack-peek (*data-stack*))))
|
||||||
|
|
||||||
|
(define-instruction (swap #x17)
|
||||||
|
(stack-swap (*data-stack*)))
|
||||||
|
|
||||||
|
(define-instruction (rot #x18)
|
||||||
|
(let* ([a (stack-pop (*data-stack*))]
|
||||||
|
[b (stack-pop (*data-stack*))]
|
||||||
|
[c (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) a)
|
||||||
|
(stack-push (*data-stack*) c)
|
||||||
|
(stack-push (*data-stack*) b)))
|
||||||
|
|
||||||
|
(define-instruction (over #x19)
|
||||||
|
(let* ([a (stack-pop (*data-stack*))]
|
||||||
|
[b (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) b)
|
||||||
|
(stack-push (*data-stack*) a)
|
||||||
|
(stack-push (*data-stack*) b)))
|
||||||
|
|
||||||
|
(define-instruction (not #x1a)
|
||||||
|
(let ([a (stack-pop (*data-stack*))])
|
||||||
|
(stack-push (*data-stack*) (if (zero? a) 1 0))))
|
||||||
|
|
||||||
|
(define-instruction (set! #x1b)
|
||||||
|
;; use let* to induce an order of evaluation
|
||||||
|
(let* ([idx (stack-pop (*data-stack*))]
|
||||||
|
[obj (stack-pop (*data-stack*))])
|
||||||
|
(stack-set! (*data-stack*) idx obj)))
|
||||||
|
|
||||||
|
(define-instruction (bye #xff)
|
||||||
|
(*vm-exit* #t)))
|
||||||
|
|
||||||
|
;;; Execution
|
||||||
|
(define* (forth-vm-run! vm #:optional debugger)
|
||||||
|
"Begin execution at pc"
|
||||||
|
(define caller (instruction-set-caller (forth-vm-instruction-set vm)
|
||||||
|
(forth-vm-registers vm)))
|
||||||
|
(parameterize ([*vm* vm])
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*vm-exit*)
|
||||||
|
(let lp ()
|
||||||
|
(when debugger
|
||||||
|
(debugger))
|
||||||
|
(define op (fetch-byte!))
|
||||||
|
(caller op)
|
||||||
|
(unless (*vm-exit*) (lp))))))
|
||||||
|
|
||||||
|
(define (forth-vm-load-program! vm prgm)
|
||||||
|
"Loads the bytevector into the vm, starting at memory address 1"
|
||||||
|
(parameterize ([*vm* vm])
|
||||||
|
(with-forth-vm-registers
|
||||||
|
(*ram*)
|
||||||
|
(let ([ram (*ram*)])
|
||||||
|
(bytevector-copy! prgm 0
|
||||||
|
ram 0
|
||||||
|
(bytevector-length prgm))))))
|
||||||
48
tests.scm
48
tests.scm
@@ -1,6 +1,6 @@
|
|||||||
(use-modules (d- test)
|
(use-modules (d- test)
|
||||||
(scmvm assembler)
|
(scmvm assembler)
|
||||||
(scmvm vm)
|
(scmvm vm forth)
|
||||||
(scmvm util stack)
|
(scmvm util stack)
|
||||||
(scmvm debugger)
|
(scmvm debugger)
|
||||||
(scmvm language assembly)
|
(scmvm language assembly)
|
||||||
@@ -120,51 +120,51 @@
|
|||||||
|
|
||||||
(define-test-suite "vm"
|
(define-test-suite "vm"
|
||||||
(define-test "adder"
|
(define-test "adder"
|
||||||
(define my-vm (make-vm forth-instruction-set))
|
(define my-vm (make-forth-vm forth-instruction-set))
|
||||||
(vm-load-program! my-vm adder-program-bytecode)
|
(forth-vm-load-program! my-vm adder-program-bytecode)
|
||||||
(vm-pc-set! my-vm 5)
|
(forth-vm-pc-set! my-vm 5)
|
||||||
(run-vm my-vm)
|
(forth-vm-run! my-vm)
|
||||||
(assert-equal 3 (vm-memory-ref my-vm 1)))
|
(assert-equal 3 (forth-vm-memory-ref my-vm 1)))
|
||||||
(define-test "fib"
|
(define-test "fib"
|
||||||
(define my-vm (make-vm forth-instruction-set))
|
(define my-vm (make-forth-vm forth-instruction-set))
|
||||||
(vm-load-program! my-vm fib-program-bytecode)
|
(forth-vm-load-program! my-vm fib-program-bytecode)
|
||||||
(vm-memory-set! my-vm 1 10)
|
(forth-vm-memory-set! my-vm 1 10)
|
||||||
(vm-pc-set! my-vm 5)
|
(forth-vm-pc-set! my-vm 5)
|
||||||
(run-vm my-vm)
|
(forth-vm-run! my-vm)
|
||||||
(assert-equal 55 (vm-memory-ref my-vm 1))))
|
(assert-equal 55 (forth-vm-memory-ref my-vm 1))))
|
||||||
|
|
||||||
(define-test-suite "debugger"
|
(define-test-suite "debugger"
|
||||||
(define-test "modify-running-program"
|
(define-test "modify-running-program"
|
||||||
(define fib-program-asm (make-assembler forth-instruction-set))
|
(define fib-program-asm (make-assembler forth-instruction-set))
|
||||||
(assemble-instructions! fib-program-asm fib-program-assembly)
|
(assemble-instructions! fib-program-asm fib-program-assembly)
|
||||||
(assembler-backpatch! fib-program-asm)
|
(assembler-backpatch! fib-program-asm)
|
||||||
(define my-debugger (make-debugger fib-program-asm))
|
(define my-debugger (make-forth-debugger fib-program-asm))
|
||||||
(define my-vm (debugger-vm my-debugger))
|
(define my-vm (debugger-vm my-debugger))
|
||||||
(define my-data (vm-data-stack my-vm))
|
(define my-data (forth-vm-data-stack my-vm))
|
||||||
(vm-memory-set! my-vm 1 10)
|
(forth-vm-memory-set! my-vm 1 10)
|
||||||
(vm-pc-set! my-vm 5)
|
(forth-vm-pc-set! my-vm 5)
|
||||||
(debugger-breakpoint-add! my-debugger 'fib)
|
(debugger-breakpoint-add! my-debugger 'fib)
|
||||||
(debugger-continue my-debugger)
|
(debugger-continue my-debugger)
|
||||||
(assert-equal 10 (stack-peek my-data))
|
(assert-equal 10 (stack-peek my-data))
|
||||||
(stack-pop my-data)
|
(stack-pop my-data)
|
||||||
(stack-push my-data 1)
|
(stack-push my-data 1)
|
||||||
(debugger-continue my-debugger)
|
(debugger-continue my-debugger)
|
||||||
(assert-equal 1 (vm-memory-ref my-vm 1)))
|
(assert-equal 1 (forth-vm-memory-ref my-vm 1)))
|
||||||
(define-test "stepping"
|
(define-test "stepping"
|
||||||
(define fib-program-asm (make-assembler forth-instruction-set))
|
(define fib-program-asm (make-assembler forth-instruction-set))
|
||||||
(assemble-instructions! fib-program-asm fib-program-assembly)
|
(assemble-instructions! fib-program-asm fib-program-assembly)
|
||||||
(assembler-backpatch! fib-program-asm)
|
(assembler-backpatch! fib-program-asm)
|
||||||
(define my-debugger (make-debugger fib-program-asm))
|
(define my-debugger (make-forth-debugger fib-program-asm))
|
||||||
(define my-vm (debugger-vm my-debugger))
|
(define my-vm (debugger-vm my-debugger))
|
||||||
(vm-memory-set! my-vm 1 10)
|
(forth-vm-memory-set! my-vm 1 10)
|
||||||
(vm-pc-set! my-vm 5)
|
(forth-vm-pc-set! my-vm 5)
|
||||||
(debugger-breakpoint-add! my-debugger 'fib)
|
(debugger-breakpoint-add! my-debugger 'fib)
|
||||||
(debugger-continue my-debugger)
|
(debugger-continue my-debugger)
|
||||||
(assert-equal 23 (vm-pc my-vm))
|
(assert-equal 23 (forth-vm-pc my-vm))
|
||||||
(debugger-step my-debugger)
|
(debugger-step my-debugger)
|
||||||
(assert-equal 24 (vm-pc my-vm)) ;; dup is a 1 byte instruction
|
(assert-equal 24 (forth-vm-pc my-vm)) ;; dup is a 1 byte instruction
|
||||||
(debugger-step my-debugger)
|
(debugger-step my-debugger)
|
||||||
(assert-equal 29 (vm-pc my-vm)) ;; push is a 5 byte instruction
|
(assert-equal 29 (forth-vm-pc my-vm)) ;; push is a 5 byte instruction
|
||||||
(debugger-continue my-debugger)
|
(debugger-continue my-debugger)
|
||||||
(assert-equal 23 (vm-pc my-vm)) ;; continue stops stepping
|
(assert-equal 23 (forth-vm-pc my-vm)) ;; continue stops stepping
|
||||||
))
|
))
|
||||||
|
|||||||
Reference in New Issue
Block a user