From e252e8eb193a13830e278d7561fbef568d874d2e Mon Sep 17 00:00:00 2001 From: Dane Johnson Date: Tue, 7 Jan 2025 10:44:39 -0600 Subject: [PATCH] Add assembler --- scmvm/assembler.scm | 49 ++++++++++++++++++++++++++ scmvm/vm.scm | 56 ++++++++++++++++-------------- tests.scm | 83 ++++++++++++++++++++++++++++++++++++++------- 3 files changed, 150 insertions(+), 38 deletions(-) create mode 100644 scmvm/assembler.scm diff --git a/scmvm/assembler.scm b/scmvm/assembler.scm new file mode 100644 index 0000000..690531a --- /dev/null +++ b/scmvm/assembler.scm @@ -0,0 +1,49 @@ +(define-module (scmvm assembler) + #:use-module (srfi srfi-1) + #:use-module (scmvm vm) + #:use-module (rnrs bytevectors) + #:use-module ((scheme base) + #:select (write-u8 write-bytevector)) + #:export (assemble)) + +(define (lookup-instruction inst) + (define inst-obj (assq inst *instruction-set*)) + (if inst-obj + 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 (find-labels inst-seq n) + (cond + [(null? inst-seq) '()] + [(label? (car inst-seq)) + (acons (car inst-seq) n (find-labels (cdr inst-seq) n))] + [else + (find-labels (cdr inst-seq) (+ n (instruction-size (caar inst-seq))))])) + +(define (write-word word) + (define bv (make-bytevector 4)) + (bytevector-s32-native-set! bv 0 word) + (write-bytevector bv)) + +(define (assemble inst-seq) + (define labels (find-labels inst-seq 0)) + (let loop ([seq inst-seq]) + (cond + [(null? seq) '()] + [(label? (car 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)))]) + (loop (cdr seq)))]))) diff --git a/scmvm/vm.scm b/scmvm/vm.scm index c3f2178..13b5b97 100644 --- a/scmvm/vm.scm +++ b/scmvm/vm.scm @@ -2,8 +2,10 @@ #:use-module ((scheme base) #:select (read-u8 read-bytevector)) #: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!)) + #:export (make-vm run-vm vm-memory-ref vm-memory-set! + *instruction-set* instruction-type instruction-code)) ;;; Data Structures (define *stack-size* 1000) @@ -78,31 +80,35 @@ (bytevector-s32-ref bv 0 (native-endianness)))) ;;; Program execution -(define *opcodes* - '((#x01 . push) - (#x02 . pop) - (#x03 . store) - (#x04 . load) - (#x05 . +) - (#x06 . -) - (#x07 . and) - (#x08 . or) - (#x09 . nand) - (#x0a . nor) - (#x0b . xor) - (#x0c . if) - (#x0d . call) - (#x0e . return) - (#x0f . >R) - (#x10 . R>) - (#x11 . =) - (#x12 . >) - (#x13 . <) - (#x14 . dup) - (#x15 . swap) - (#x16 . jmp))) +(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))) -(define op-lookup (cute assq-ref *opcodes* <>)) +(define instruction-code cadr) +(define instruction-type caddr) + +(define (op-lookup code) + (car (find (lambda (x) (= (instruction-code x) code)) *instruction-set*))) (define (binop-lookup op) (case (op-lookup op) diff --git a/tests.scm b/tests.scm index dbce336..72dca79 100644 --- a/tests.scm +++ b/tests.scm @@ -1,19 +1,64 @@ -(use-modules (d- test)) - - -;;; VM tests -(use-modules (scmvm vm) +(use-modules (d- test) + (scmvm assembler) + (scmvm vm) (rnrs bytevectors) - (rnrs io ports)) + (rnrs io ports) + ((scheme base) + #:select (open-output-bytevector get-output-bytevector))) + +;;; Data +(define adder-program-asm + '((push 1) + (push 2) + (+) + (store #x01))) -(define adder-program +(define fib-program-asm + '( (load 1) + (call fib) + (jmp cleanup) + fib + (dup) + (push 0) + (=) + (if not0) + (pop) + (pop) + (push 0) + (return) + not0 + (pop) + (dup) + (push 1) + (=) + (if not1) + (pop) + (pop) + (push 1) + (return) + not1 + (pop) + (push 1) + (-) + (dup) + (call fib) + (swap) + (push 1) + (-) + (call fib) + (+) + (return) + cleanup + (store #x1))) + +(define adder-program-bytecode #vu8(#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 )) -(define fib-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 @@ -52,15 +97,27 @@ #x03 1 0 0 0 ; 83 store fib(n) to memory address 0x01 )) -(define-test-suite "VM" + +;;; Tests +(define-test-suite "assembler" + (define-test "adder" + (define out (open-output-bytevector)) + (with-output-to-port out (lambda () (assemble adder-program-asm))) + (assert-equal adder-program-bytecode (get-output-bytevector out))) + (define-test "fib" + (define out (open-output-bytevector)) + (with-output-to-port out (lambda () (assemble fib-program-asm))) + (assert-equal fib-program-bytecode (get-output-bytevector out)))) + +(define-test-suite "vm" (define-test "adder" (define my-vm (make-vm)) - (define my-program (open-bytevector-input-port adder-program)) + (define my-program (open-bytevector-input-port adder-program-bytecode)) (run-vm my-vm my-program) (assert-equal 3 (vm-memory-ref my-vm 1))) (define-test "fib" (define my-vm (make-vm)) - (vm-memory-set! my-vm 1 6) - (define my-program (open-bytevector-input-port fib-program)) + (vm-memory-set! my-vm 1 10) + (define my-program (open-bytevector-input-port fib-program-bytecode)) (run-vm my-vm my-program) - (assert-equal 8 (vm-memory-ref my-vm 1)))) + (assert-equal 55 (vm-memory-ref my-vm 1))))