From 51e34c97506eab6e07e5ec35bcf2dc5dd42471d0 Mon Sep 17 00:00:00 2001 From: Dane Johnson Date: Sun, 15 Feb 2026 13:30:54 -0600 Subject: [PATCH] Delete old vm --- scmvm/assembler.scm | 2 +- scmvm/debugger.scm | 2 +- scmvm/language/assembly.scm | 2 +- scmvm/util/stack.scm | 5 +- scmvm/vm.scm | 243 +++--------------------------------- scmvm/vm/forth.scm | 2 +- scmvm/vm2.scm | 39 ------ 7 files changed, 25 insertions(+), 270 deletions(-) delete mode 100644 scmvm/vm2.scm diff --git a/scmvm/assembler.scm b/scmvm/assembler.scm index 697394e..7249bdb 100644 --- a/scmvm/assembler.scm +++ b/scmvm/assembler.scm @@ -1,5 +1,5 @@ (define-module (scmvm assembler) - #:use-module (scmvm vm2) + #:use-module (scmvm vm) #:use-module (srfi srfi-26) #:use-module (srfi srfi-9) #:use-module (rnrs bytevectors) diff --git a/scmvm/debugger.scm b/scmvm/debugger.scm index d33a10a..f0a77d8 100644 --- a/scmvm/debugger.scm +++ b/scmvm/debugger.scm @@ -1,6 +1,6 @@ (define-module (scmvm debugger) #:use-module (scmvm assembler) - #:use-module (scmvm vm2) + #:use-module (scmvm vm) #:use-module (scmvm vm forth) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) diff --git a/scmvm/language/assembly.scm b/scmvm/language/assembly.scm index c4648da..4ab810a 100644 --- a/scmvm/language/assembly.scm +++ b/scmvm/language/assembly.scm @@ -1,5 +1,5 @@ (define-module (scmvm language assembly) - #:use-module (scmvm vm2) + #:use-module (scmvm vm) #:use-module (scmvm assembler) #:use-module (srfi srfi-1) #:use-module ((scheme base) #:select (write-bytevector)) diff --git a/scmvm/util/stack.scm b/scmvm/util/stack.scm index 9bffa80..9930c4b 100644 --- a/scmvm/util/stack.scm +++ b/scmvm/util/stack.scm @@ -1,7 +1,8 @@ (define-module (scmvm util stack) #:use-module (srfi srfi-43) - #:export (make-stack stack-ref stack->list stack-set! - (push . stack-push) (pop . stack-pop) (peek . stack-peek) (swap . stack-swap))) + #:replace (make-stack) + #: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 diff --git a/scmvm/vm.scm b/scmvm/vm.scm index 2d7d9d8..6b570fc 100644 --- a/scmvm/vm.scm +++ b/scmvm/vm.scm @@ -1,37 +1,16 @@ (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) - #: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) + #:use-module (ice-9 hash-table) + #:export (define-instruction-set + instruction-lookup + instruction-set-caller + instruction-name + instruction-code + register-set)) -(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 (define-syntax define-instruction-set (syntax-rules (define-instruction) - [(_ set-name (define-instruction (name opcode) impl ...) ...) + [(_ (set-name reg ...) (define-instruction (name opcode) impl ...) ...) (define (set-name dispatch) (case dispatch [(lookup) @@ -40,207 +19,21 @@ [(name) '(name opcode)] ... [else #f]))] [(call) - (lambda (op) - (case op - [(opcode) impl ...] ...))]))])) + (lambda (registers) + (let ([reg (hash-ref registers 'reg)] ...) + (parameterize ([reg #f] ...) + (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-set-caller instruction-set registers) + ((instruction-set 'call) registers)) (define instruction-name car) (define instruction-code cadr) -(define-instruction-set forth-instruction-set - (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*) (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 - (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)))) +(define (register-set names) + (alist->hash-table (map (lambda (n) (cons n (make-parameter #f))) names))) diff --git a/scmvm/vm/forth.scm b/scmvm/vm/forth.scm index 3217a80..dcddb3a 100644 --- a/scmvm/vm/forth.scm +++ b/scmvm/vm/forth.scm @@ -1,5 +1,5 @@ (define-module (scmvm vm forth) - #:use-module (scmvm vm2) + #:use-module (scmvm vm) #:use-module (scmvm util stack) #:use-module ((scheme base) #:select (read-u8 read-bytevector)) diff --git a/scmvm/vm2.scm b/scmvm/vm2.scm deleted file mode 100644 index 5755e16..0000000 --- a/scmvm/vm2.scm +++ /dev/null @@ -1,39 +0,0 @@ -(define-module (scmvm vm2) - #:use-module (ice-9 hash-table) - #:export (define-instruction-set - instruction-lookup - instruction-set-caller - instruction-name - instruction-code - register-set)) - -;;; Instructions -(define-syntax define-instruction-set - (syntax-rules (define-instruction) - [(_ (set-name reg ...) (define-instruction (name opcode) impl ...) ...) - (define (set-name dispatch) - (case dispatch - [(lookup) - (lambda (lookup) - (case lookup - [(name) '(name opcode)] ... - [else #f]))] - [(call) - (lambda (registers) - (let ([reg (hash-ref registers 'reg)] ...) - (parameterize ([reg #f] ...) - (lambda (op) - (case op - [(opcode) impl ...] ...)))))]))])) - -(define (instruction-lookup isa name) - ((isa 'lookup) name)) - -(define (instruction-set-caller instruction-set registers) - ((instruction-set 'call) registers)) - -(define instruction-name car) -(define instruction-code cadr) - -(define (register-set names) - (alist->hash-table (map (lambda (n) (cons n (make-parameter #f))) names)))