dane/scm-to-vm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Pluggable instruction sets

Browse Source
This commit is contained in:
Dane Johnson
2026-02-10 10:58:48 -06:00
parent e4fe2c6bff
commit 4280841719
6 changed files with 226 additions and 188 deletions
Download Patch File Download Diff File Expand all files Collapse all files

45
scmvm/language/assembly.scm
View File

@@ -3,7 +3,7 @@
#:use-module (scmvm assembler)
#:use-module (srfi srfi-1)
#:use-module ((scheme base) #:select (write-bytevector))
#:export (assemble assemble-instructions))
#:export (assemble assemble-instructions!))
(define *aliases*
'((if . branch)))
@@ -11,10 +11,10 @@
(define (or-alias inst)
(or (assq-ref *aliases* inst) inst))
(define (lookup-instruction inst)
(define inst-obj (assq (or-alias inst) *instruction-set*))
(define (lookup-instruction isa inst)
(define inst-obj (instruction-lookup isa (or-alias inst)))
(or inst-obj
(error (format #f "could not find instruction ~a" inst))))
(error (format #f "could not find instruction ~a in ISA ~a" inst isa))))
(define label? (negate pair?))
(define (variable? x)
@@ -32,28 +32,29 @@
(emit-literal asm v)
(emit-reference asm v)))
(define (assemble-instructions asm inst-seq)
(define (assemble-instructions! asm inst-seq)
(when (pair? inst-seq)
(define next-inst (car inst-seq))
(cond
[(label? (car inst-seq))
(emit-label asm (car inst-seq))]
[(variable? (car inst-seq))
(emit-label asm (second (car inst-seq)))
(emit-literal asm (third (car inst-seq)))]
[(ref? (car inst-seq))
(emit-push asm (second (car inst-seq)))
[(label? next-inst)
(emit-label asm next-inst)]
[(variable? next-inst)
(emit-label asm (second next-inst))
(emit-literal asm (third next-inst))]
[(ref? next-inst)
(emit-push asm (second next-inst))
(emit-instruction asm '@)]
[(set!? (car inst-seq))
(emit-push asm (second (car inst-seq)))
[(set!? next-inst)
(emit-push asm (second next-inst))
(emit-instruction asm '!)]
[(push? (car inst-seq))
(emit-push asm (second (car inst-seq)))]
[(push? next-inst)
(emit-push asm (second next-inst))]
[else
(emit-instruction asm (instruction-name (lookup-instruction (first (car inst-seq)))))])
(assemble-instructions asm (cdr inst-seq))))
(emit-instruction asm (instruction-name (lookup-instruction (assembler-instruction-set asm) (first next-inst))))])
(assemble-instructions! asm (cdr inst-seq))))
(define (assemble instructions port)
(define asm (make-assembler))
(assemble-instructions asm instructions)
(finalize-references asm)
(define (assemble instructions instruction-set port)
(define asm (make-assembler instruction-set))
(assemble-instructions! asm instructions)
(assembler-backpatch! asm)
(assembler-dump-program asm port))

11
scmvm/language/scheme.scm
View File

@@ -299,6 +299,7 @@
(primitive-eval `(display (call/cc (lambda (ktail) ,(ir-convert prgm)))))
(newline))
(ir-interpreter))
;; Optimization
(define-syntax-rule (define-cps-type name field ...)
(begin
@@ -349,11 +350,11 @@
[($ $constant val) val]
[($ $primitive name) `(cps-prim ,name)]
[($ $var name) name]
[($ $abstraction vars body ktail) `(lambda (,@vars ,ktail) ,body)]
[($ $alternative pred kt kf) `(if ,pred ,kt ,kf)]
[($ $fix vars exps body) `(letrec ,(zip vars exps) ,body)]
[($ $assignment var expr cont) `(set!-then ,var ,expr ,cont)]
[($ $application fun args ktail) `(,fun ,@args ,ktail)]
[($ $abstraction vars body ktail) `(lambda (,@(map unparse-cps vars) ,ktail) ,(unparse-cps body))]
[($ $alternative pred kt kf) `(if ,(unparse-cps pred) ,kt ,kf)]
[($ $fix vars exps body) `(letrec ,(zip (map unparse-cps vars) (map unparse-cps exps)) ,(unparse-cps body))]
[($ $assignment var expr cont) `(set!-then ,(unparse-cps var) ,(unparse-cps expr) ,(unparse-cps cont))]
[($ $application fun args ktail) `(,(unparse-cps fun) ,@(map unparse-cps args) ,ktail)]
[_ (error "Unexpected cps while unparsing" exp)]))
;; Compilation