Move common elements of the assembler (basically everything) to common file

scmvm/language/assembler.scm

@@ -1,12 +1,9 @@
 (define-module (scmvm language assembler)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-26)
   #:use-module (scmvm vm)
-  #:use-module (rnrs bytevectors)
+  #:use-module (scmvm language common)
+  #:use-module (srfi srfi-1)
   #:use-module ((scheme base) #:select (write-bytevector))
-  #:export (assemble (make-assembler* . make-assembler)
-	    assembler-labels update-references))
+  #:export (assemble))
 
 (define *aliases*
   '((if . branch)))
@@ -33,46 +30,6 @@
        (not (ref? x))
        (not (set!? x))))
 
-(define (make-label) (cons #f '()))
-
-(define-record-type <assembler>
-  (make-assembler pos buf labels source)
-  assembler?
-  (pos assembler-pos assembler-pos-set!)
-  (buf assembler-buf assembler-buf-set!)
-  (labels assembler-labels)
-  (source assembler-source))
-
-(define (make-assembler*)
-  (make-assembler 0 (make-bytevector 1024) (make-hash-table) (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-instruction asm inst)
   (let ([inst-object (lookup-instruction (car inst))])
     (write-byte (instruction-code inst-object) asm)
@@ -85,9 +42,6 @@
 	    (assembler-label-add-reference asm (cadr inst) (assembler-pos asm))))
       (assembler-pos-set! asm (+ (assembler-pos asm) 4)))))
 
-(define (emit-label asm name)
-  (assembler-label-add-value asm name (assembler-pos asm)))
-
 (define (assemble-instructions asm inst-seq)
   (when (pair? inst-seq)
     (cond
@@ -107,16 +61,9 @@
       (emit-instruction asm (car inst-seq))])
     (assemble-instructions asm (cdr inst-seq))))
 
-(define (update-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 (assemble instructions port)
-  (define asm (make-assembler*))
+  (define asm (make-assembler))
   (assemble-instructions asm instructions)
-  (update-references asm)
+  (finalize-references asm)
   (write-bytevector (assembler-buf asm) port 0 (assembler-pos asm))
   asm)

scmvm/language/common.scm

@@ -0,0 +1,67 @@
+(define-module (scmvm language common)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-9)
+  #:use-module (rnrs bytevectors)
+  #:export (<assembler>
+	    (make-assembler* . make-assembler)
+	    assembler?
+	    assembler-labels
+	    assembler-pos
+	    assembler-buf
+	    assembler-pos-set!
+	    assembler-buf-set!
+	    assembler-label-add-reference
+	    assembler-label-add-value
+	    write-byte
+	    write-word
+	    emit-label
+	    finalize-references))
+
+(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 (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 (emit-label asm name)
+  (assembler-label-add-value asm name (assembler-pos asm)))

tests.scm

@@ -1,4 +1,5 @@
 (use-modules (d- test)
+	     (scmvm language common)
              (scmvm language assembler)
              (scmvm vm)
 	     (scmvm debugger)
@@ -103,7 +104,6 @@
        #x02          ; Store fib(n)
        #xff          ; Exit program
        ))
-
 
 ;;; Tests
 (define-test-suite "assembler"