From 490840e5774380bc0b58583964173cd50b679dfc Mon Sep 17 00:00:00 2001 From: Dane Johnson Date: Wed, 3 Sep 2025 19:37:13 -0500 Subject: [PATCH] Stateful assembler like Guile, hope to extend to interface for compiler --- scmvm/debugger.scm | 14 ++-- scmvm/language/assembler.scm | 142 ++++++++++++++++++++++------------- 2 files changed, 95 insertions(+), 61 deletions(-) diff --git a/scmvm/debugger.scm b/scmvm/debugger.scm index 56141c8..1e8d790 100644 --- a/scmvm/debugger.scm +++ b/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) diff --git a/scmvm/language/assembler.scm b/scmvm/language/assembler.scm index c6d59f7..840294b 100644 --- a/scmvm/language/assembler.scm +++ b/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 + (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) - (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))])) +(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) 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)