Move further code to common, rename to assembler (last restructure I promise)

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 <assembler>
+  (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)))

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 <debugger>
-  (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 (make-debugger* asm)
-  (define-values (prgm asm)
+  (define prgm
     (call-with-values open-bytevector-output-port
       (lambda (port get-bv)
-        (define asm (assemble source port))
+	(assembler-dump-program asm port)
-        (values (get-bv) asm))))
+	(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)

scmvm/language/assembler.scm

@@ -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)

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))

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)

tests.scm

@@ -1,6 +1,6 @@
 (use-modules (d- test)
-	     (scmvm language common)
+	     (scmvm assembler)
-             (scmvm language 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)