Stateful assembler like Guile, hope to extend to interface for compiler

scmvm/debugger.scm

@@ -1,5 +1,5 @@
 (define-module (scmvm debugger)
-  #:use-module (scmvm assembler)
+  #:use-module (scmvm language assembler)
   #:use-module (scmvm vm)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -23,12 +23,12 @@
   (continuation debugger-continuation debugger-continuation-set!)
   (stepping debugger-stepping? debugger-stepping-set!))
 
-(define (make-breakpoints labels)
+(define (make-breakpoints asm)
   (define the-breakpoints '())
   (define (->index index/label)
     (if (number? index/label)
         index/label
-        (assq-ref labels index/label)))
+        (car (hash-ref (assembler-labels asm) index/label))))
   (define-syntax-rule (ilambda (i) e ...)
     (lambda (v) (let ([i (->index v)]) e ...)))
   (match-lambda
@@ -44,11 +44,11 @@
      (ilambda (i) (assq-ref the-breakpoints i))]))
 
 (define (make-debugger* source)
-  (define-values (prgm symbols)
+  (define-values (prgm asm)
     (call-with-values open-bytevector-output-port
       (lambda (port get-bv)
-        (define symbols (assemble source port))
-        (values (get-bv) symbols))))
+        (define asm (assemble source port))
+        (values (get-bv) asm))))
   (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 symbols) #f #f))
+  (set! the-debugger (make-debugger vm source (make-breakpoints asm) #f #f))
   (debugger-breakpoint-add! the-debugger 1)
   (reset (run-vm vm))
   the-debugger)

scmvm/language/assembler.scm

@@ -1,11 +1,12 @@
 (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 (rnrs io ports)
-  #:use-module ((scheme base)
-                #:select (write-u8 write-bytevector))
-  #:export (assemble))
+  #:use-module ((scheme base) #:select (write-bytevector))
+  #:export (assemble (make-assembler* . make-assembler)
+	    assembler-labels update-references))
 
 (define *aliases*
   '((if . branch)))
@@ -31,58 +32,91 @@
        (not (variable? x))
        (not (ref? x))
        (not (set!? x))))
-(define (instruction-size inst)
-  (case (car inst)
-    [(push) 5]
-    [(ref set!) 6]
-    [else 1]))
 
-(define (label-pass instructions address)
-  (cond
-   [(null? instructions) '()]
-   [(label? (car instructions))
-    (acons (car instructions) address (label-pass (cdr instructions) address))]
-   [(variable? (car instructions))
-    (acons (cadar instructions) address (label-pass (cdr instructions) (+ address 4)))]
-   [else
-    (label-pass (cdr instructions) (+ address (instruction-size (car instructions))))]))
+(define (make-label) (cons #f '()))
 
-(define (write-word word)
-  (define bv (make-bytevector 4))
-  (bytevector-u32-native-set! bv 0 word)
-  (write-bytevector bv))
+(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 (assembly-pass seq labels)
-  (cond
-   [(null? seq) '()]
-   [(label? (car seq)) (assembly-pass (cdr seq) labels)]
-   [(variable? (car seq))
-    (write-word (caddar seq))
-    (assembly-pass (cdr seq) labels)]
-   [(ref? (car seq))
-    (write-u8 (cadr (lookup-instruction 'push)))
-    (write-word (assq-ref labels (cadar seq)))
-    (write-u8 (cadr (lookup-instruction '@)))
-    (assembly-pass (cdr seq) labels)]
-   [(set!? (car seq))
-    (write-u8 (cadr (lookup-instruction 'push)))
-    (write-word (assq-ref labels (cadar seq)))
-    (write-u8 (cadr (lookup-instruction '!)))
-    (assembly-pass (cdr seq) labels)]
-   [else
-    (let* ([inst (car seq)]
-           [inst-obj (lookup-instruction (car inst))])
-      (write-u8 (instruction-code inst-obj))
-      (when (eq? (car inst) 'push)
+(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)
+    (assembler-pos-set! asm (+ (assembler-pos asm) 1))
+    (when (not (null? (cdr inst)))
       (if (number? (cadr inst))
-            (write-word (cadr inst))
-            (let ([address (assq-ref labels (cadr inst))])
-              (if address
-                  (write-word (assq-ref labels (cadr inst)))
-                  (error (format #f "Could not find label ~a" (cadr inst)))))))
-      (assembly-pass (cdr seq) labels))]))
+	  (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 (emit-label asm name)
+  (assembler-label-add-value asm name (assembler-pos asm)))
+
+(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 (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 labels (label-pass instructions 1))
-  (with-output-to-port port (lambda () (assembly-pass instructions labels)))
-  labels)
+  (define asm (make-assembler*))
+  (assemble-instructions asm instructions)
+  (update-references asm)
+  (write-bytevector (assembler-buf asm) port 0 (assembler-pos asm))
+  asm)