From 4e8e3ef8c4231ec4f24bf6c828c335a7fcc6deca Mon Sep 17 00:00:00 2001 From: Dane Johnson Date: Thu, 4 Sep 2025 19:48:26 -0500 Subject: [PATCH] Move common elements of the assembler (basically everything) to common file --- scmvm/language/assembler.scm | 63 +++------------------------------ scmvm/language/common.scm | 67 ++++++++++++++++++++++++++++++++++++ tests.scm | 2 +- 3 files changed, 73 insertions(+), 59 deletions(-) create mode 100644 scmvm/language/common.scm diff --git a/scmvm/language/assembler.scm b/scmvm/language/assembler.scm index 840294b..130d5b3 100644 --- a/scmvm/language/assembler.scm +++ b/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 - (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) diff --git a/scmvm/language/common.scm b/scmvm/language/common.scm new file mode 100644 index 0000000..9ca23f5 --- /dev/null +++ b/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 ( + (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 + (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))) diff --git a/tests.scm b/tests.scm index 43ac735..f0f7af5 100644 --- a/tests.scm +++ b/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"