123 lines
4.1 KiB
Scheme
123 lines
4.1 KiB
Scheme
(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 ((scheme base) #:select (write-bytevector))
|
|
#:export (assemble (make-assembler* . make-assembler)
|
|
assembler-labels update-references))
|
|
|
|
(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 (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)
|
|
(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 asm (make-assembler*))
|
|
(assemble-instructions asm instructions)
|
|
(update-references asm)
|
|
(write-bytevector (assembler-buf asm) port 0 (assembler-pos asm))
|
|
asm)
|