diff --git a/scmvm/assembler.scm b/scmvm/assembler.scm new file mode 100644 index 0000000..20f08b9 --- /dev/null +++ b/scmvm/assembler.scm @@ -0,0 +1,80 @@ +(define-module (scmvm assembler) + #:use-module (scmvm vm) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-9) + #:use-module (rnrs bytevectors) + #:use-module ((scheme base) #:select (write-bytevector)) + #:export ((make-assembler* . make-assembler) + assembler? + assembler-labels + emit-label + emit-instruction + emit-literal + emit-reference + finalize-references + assembler-dump-program)) + +(define (make-label) (cons #f '())) + +(define-record-type + (make-assembler pos buf labels) + assembler? + (pos assembler-pos assembler-pos-set!) + (buf assembler-buf assembler-buf-set!) + (labels assembler-labels)) + +(define (make-assembler*) + (make-assembler 0 (make-bytevector 1024) (make-hash-table))) + +(define (assembler-buf-grow! asm) + (let ([buf (make-bytevector (ash (bytevector-length (assembler-buf asm)) -1))]) + (bytevector-copy! (assembler-buf asm) 0 buf 0 (bytevector-length (assembler-buf asm))) + (assembler-buf-set! asm buf))) + +(define* (write-word word asm #:optional (pos (assembler-pos asm))) + (when (> (+ pos 4) (bytevector-length (assembler-buf asm))) + (assembler-buf-grow! asm)) + (bytevector-u32-native-set! (assembler-buf asm) pos word)) + +(define* (write-byte byte asm #:optional (pos (assembler-pos asm))) + (when (> (+ pos 1) (bytevector-length (assembler-buf asm))) + (assembler-buf-grow! asm)) + (bytevector-u8-set! (assembler-buf asm) pos byte)) + +(define (assembler-label-add-reference asm name addr) + (when (not (hash-ref (assembler-labels asm) name)) + (hash-set! (assembler-labels asm) name (make-label))) + (let ([label (hash-ref (assembler-labels asm) name)]) + (set-cdr! label (cons addr (cdr label))))) + +(define (assembler-label-add-value asm name val) + (when (not (hash-ref (assembler-labels asm) name)) + (hash-set! (assembler-labels asm) name (make-label))) + ;; 1+ to fudge for null pointers + (set-car! (hash-ref (assembler-labels asm) name) (1+ val))) + +(define (emit-label asm name) + (assembler-label-add-value asm name (assembler-pos asm))) + +(define (emit-instruction asm inst) + (let ([inst-object (assq inst *instruction-set*)]) + (write-byte (instruction-code inst-object) asm) + (assembler-pos-set! asm (+ (assembler-pos asm) 1)))) + +(define (emit-literal asm val) + (write-word val asm) + (assembler-pos-set! asm (+ (assembler-pos asm) 4))) + +(define (emit-reference asm name) + (assembler-label-add-reference asm name (assembler-pos asm)) + (assembler-pos-set! asm (+ (assembler-pos asm) 4))) + +(define (finalize-references asm) + (define (install-location _name label) + (for-each + (cute write-word (car label) asm <>) + (cdr label))) + (hash-for-each install-location (assembler-labels asm))) + +(define (assembler-dump-program asm port) + (write-bytevector (assembler-buf asm) port 0 (assembler-pos asm))) diff --git a/scmvm/debugger.scm b/scmvm/debugger.scm index 1e8d790..3084325 100644 --- a/scmvm/debugger.scm +++ b/scmvm/debugger.scm @@ -1,5 +1,5 @@ (define-module (scmvm debugger) - #:use-module (scmvm language assembler) + #:use-module (scmvm assembler) #:use-module (scmvm vm) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -15,10 +15,10 @@ debugger-step debugger-continue)) (define-record-type - (make-debugger vm source breakpoints continuation stepping) + (make-debugger vm asm breakpoints continuation stepping) debugger? (vm debugger-vm) - (source debugger-source) + (asm debugger-asm) (breakpoints debugger-breakpoints) (continuation debugger-continuation debugger-continuation-set!) (stepping debugger-stepping? debugger-stepping-set!)) @@ -43,12 +43,12 @@ ['ref (ilambda (i) (assq-ref the-breakpoints i))])) -(define (make-debugger* source) - (define-values (prgm asm) +(define (make-debugger* asm) + (define prgm (call-with-values open-bytevector-output-port (lambda (port get-bv) - (define asm (assemble source port)) - (values (get-bv) asm)))) + (assembler-dump-program asm port) + (get-bv)))) (define the-debugger #f) (define (debug) (shift k @@ -58,7 +58,7 @@ (k)))) (define vm (make-vm #:debugger debug)) (vm-load-program! vm prgm) - (set! the-debugger (make-debugger vm source (make-breakpoints asm) #f #f)) + (set! the-debugger (make-debugger vm asm (make-breakpoints asm) #f #f)) (debugger-breakpoint-add! the-debugger 1) (reset (run-vm vm)) the-debugger) diff --git a/scmvm/language/assembler.scm b/scmvm/language/assembler.scm deleted file mode 100644 index 130d5b3..0000000 --- a/scmvm/language/assembler.scm +++ /dev/null @@ -1,69 +0,0 @@ -(define-module (scmvm language assembler) - #:use-module (scmvm vm) - #:use-module (scmvm language common) - #:use-module (srfi srfi-1) - #:use-module ((scheme base) #:select (write-bytevector)) - #:export (assemble)) - -(define *aliases* - '((if . branch))) - -(define (or-alias inst) - (or (assq-ref *aliases* inst) inst)) - -(define (lookup-instruction inst) - (define inst-obj (assq (or-alias inst) *instruction-set*)) - (if inst-obj - inst-obj - (error (format #f "could not find instruction ~a" inst)))) - -(define label? (compose not pair?)) -(define (variable? x) - (and (pair? x) (eq? (car x) 'variable))) -(define (ref? x) - (and (pair? x) (eq? (car x) 'ref))) -(define (set!? x) - (and (pair? x) (eq? (car x) 'set!))) -(define (instruction? x) - (and (not (label? x)) - (not (variable? x)) - (not (ref? x)) - (not (set!? x)))) - -(define (emit-instruction asm inst) - (let ([inst-object (lookup-instruction (car inst))]) - (write-byte (instruction-code inst-object) asm) - (assembler-pos-set! asm (+ (assembler-pos asm) 1)) - (when (not (null? (cdr inst))) - (if (number? (cadr inst)) - (write-word (cadr inst) asm) - (begin - (write-word 0 asm) - (assembler-label-add-reference asm (cadr inst) (assembler-pos asm)))) - (assembler-pos-set! asm (+ (assembler-pos asm) 4))))) - -(define (assemble-instructions asm inst-seq) - (when (pair? inst-seq) - (cond - [(label? (car inst-seq)) - (emit-label asm (car inst-seq))] - [(variable? (car inst-seq)) - (emit-label asm (second (car inst-seq))) - (write-word (third (car inst-seq)) asm) - (assembler-pos-set! asm (+ (assembler-pos asm) 4))] - [(ref? (car inst-seq)) - (emit-instruction asm `(push ,(second (car inst-seq)))) - (emit-instruction asm '(@))] - [(set!? (car inst-seq)) - (emit-instruction asm `(push ,(second (car inst-seq)))) - (emit-instruction asm '(!))] - [else - (emit-instruction asm (car inst-seq))]) - (assemble-instructions asm (cdr inst-seq)))) - -(define (assemble instructions port) - (define asm (make-assembler)) - (assemble-instructions asm instructions) - (finalize-references asm) - (write-bytevector (assembler-buf asm) port 0 (assembler-pos asm)) - asm) diff --git a/scmvm/language/assembly.scm b/scmvm/language/assembly.scm new file mode 100644 index 0000000..4c82741 --- /dev/null +++ b/scmvm/language/assembly.scm @@ -0,0 +1,60 @@ +(define-module (scmvm language assembly) + #:use-module (scmvm vm) + #:use-module (scmvm assembler) + #:use-module (srfi srfi-1) + #:use-module ((scheme base) #:select (write-bytevector)) + #:export (assemble assemble-instructions)) + +(define *aliases* + '((if . branch))) + +(define (or-alias inst) + (or (assq-ref *aliases* inst) inst)) + +(define (lookup-instruction inst) + (define inst-obj (assq (or-alias inst) *instruction-set*)) + (if inst-obj + inst-obj + (error (format #f "could not find instruction ~a" inst)))) + +(define label? (negate pair?)) +(define (variable? x) + (and (pair? x) (eq? (car x) 'variable))) +(define (ref? x) + (and (pair? x) (eq? (car x) 'ref))) +(define (set!? x) + (and (pair? x) (eq? (car x) 'set!))) +(define (push? x) + (and (pair? x) (eq? (car x) 'push))) + +(define (emit-push asm v) + (emit-instruction asm 'push) + (if (number? v) + (emit-literal asm v) + (emit-reference asm v))) + +(define (assemble-instructions asm inst-seq) + (when (pair? inst-seq) + (cond + [(label? (car inst-seq)) + (emit-label asm (car inst-seq))] + [(variable? (car inst-seq)) + (emit-label asm (second (car inst-seq))) + (emit-literal asm (third (car inst-seq)))] + [(ref? (car inst-seq)) + (emit-push asm (second (car inst-seq))) + (emit-instruction asm '@)] + [(set!? (car inst-seq)) + (emit-push asm (second (car inst-seq))) + (emit-instruction asm '!)] + [(push? (car inst-seq)) + (emit-push asm (second (car inst-seq)))] + [else + (emit-instruction asm (instruction-name (lookup-instruction (first (car inst-seq)))))]) + (assemble-instructions asm (cdr inst-seq)))) + +(define (assemble instructions port) + (define asm (make-assembler)) + (assemble-instructions asm instructions) + (finalize-references asm) + (assembler-dump-program asm port)) diff --git a/scmvm/vm.scm b/scmvm/vm.scm index f2f921d..277ac7e 100644 --- a/scmvm/vm.scm +++ b/scmvm/vm.scm @@ -13,7 +13,7 @@ vm-data-stack vm-ret-stack vm-debugger vm-debugger-set! vm-pc vm-pc-set! - *instruction-set* instruction-type instruction-code)) + *instruction-set* instruction-name instruction-code)) ;;; Data Structures (define *stack-size* 512) @@ -118,6 +118,7 @@ (not #x1a) (bye #xff))) +(define instruction-name car) (define instruction-code cadr) (define (op-lookup code) diff --git a/tests.scm b/tests.scm index f0f7af5..647a096 100644 --- a/tests.scm +++ b/tests.scm @@ -1,6 +1,6 @@ (use-modules (d- test) - (scmvm language common) - (scmvm language assembler) + (scmvm assembler) + (scmvm language assembly) (scmvm vm) (scmvm debugger) (rnrs bytevectors) @@ -9,7 +9,7 @@ #:select (open-output-bytevector get-output-bytevector))) ;;; Data -(define adder-program-asm +(define adder-program-assembly '((variable result 0) (push 1) (push 2) @@ -18,7 +18,7 @@ (!) (bye))) -(define fib-program-asm +(define fib-program-assembly '( (variable result 0) (ref result) (push fib) @@ -106,14 +106,14 @@ )) ;;; Tests -(define-test-suite "assembler" +(define-test-suite "assembly" (define-test "adder" (define out (open-output-bytevector)) - (assemble adder-program-asm out) + (assemble adder-program-assembly out) (assert-equal adder-program-bytecode (get-output-bytevector out))) (define-test "fib" (define out (open-output-bytevector)) - (assemble fib-program-asm out) + (assemble fib-program-assembly out) (assert-equal fib-program-bytecode (get-output-bytevector out)))) (define-test-suite "vm" @@ -133,6 +133,9 @@ (define-test-suite "debugger" (define-test "modify-running-program" + (define fib-program-asm (make-assembler)) + (assemble-instructions fib-program-asm fib-program-assembly) + (finalize-references fib-program-asm) (define my-debugger (make-debugger fib-program-asm)) (define my-vm (debugger-vm my-debugger)) (define my-data (vm-data-stack my-vm)) @@ -146,6 +149,9 @@ (debugger-continue my-debugger) (assert-equal 1 (vm-memory-ref my-vm 1))) (define-test "stepping" + (define fib-program-asm (make-assembler)) + (assemble-instructions fib-program-asm fib-program-assembly) + (finalize-references fib-program-asm) (define my-debugger (make-debugger fib-program-asm)) (define my-vm (debugger-vm my-debugger)) (vm-memory-set! my-vm 1 10)