(define emu
(lambda (program)
(emu-startup (emu-assemble program))))
(define sparc-assemble
(lambda (code file)
(let ([op (open-output-file file 'replace)])
(parameterize ([current-output-port op])
(sparc-spit (registerize code)))
(close-output-port op))))
(define emu-assemble
(lambda (code)
(emu-transform (registerize code))))
(define registerize
(letrec ([list-index
(lambda (item ls acc)
(if (null? ls) #f
(if (eq? (car ls) item) acc
(list-index item (cdr ls) (add1 acc)))))]
[regs '(pc fp cp ap ac t1 t2 t3)])
(lambda (thing)
(cond
[(pair? thing)
(let ([x (list-index (car thing) regs 0)])
(if x
`(reg-off (reg ,x) ,(cadr thing))
(map registerize thing)))]
[(and (symbol? thing) (list-index thing regs 0)) =>
(lambda (x)
`(reg ,x))]
[else thing]))))
(define sparc-spit
(lambda (ls)
(define print-elem
(lambda (obj delim)
(cond
[(pair? obj)
(record-case obj
[reg (num)
(printf "~a%l~s" delim num)]
[reg-off (reg off)
(let ([num (cadr reg)])
(printf "~a[%l~s~a~s]" delim
num (if (nonnegative? off) "+" "") off))])]
[(string? obj)
(printf "~c! ~a " #\tab obj)]
[else (printf "~a~a" delim obj)])))
(printf "~c.align 4~n" #\tab)
(printf "~c.global _scheme_entry~n" #\tab)
(let loop ([ls (cdr ls)])
(unless (null? ls)
(let ([inst (car ls)])
(case (car inst)
[(comment)
(printf "~c~c! ~a " #\tab #\tab (cadr inst))]
[(label)
(printf "~a:" (cadr inst))]
[(nop)
(printf "~c~s" #\tab 'nop)]
[else
(let ([first (cadr inst)]
[rest (cddr inst)])
(printf "~c~s~c" #\tab (car inst) #\tab)
(print-elem first "")
(for-each (lambda (x) (print-elem x ", "))
rest))]))
(newline)
(loop (cdr ls))))))
(define emu-transform
(lambda (ls)
(let ([code-vec (make-vector (sub1 (length ls)))])
(let loop ([pos 0] [ls (cdr ls)] [atable '()] [back '()])
(if (null? ls)
(for-each
(lambda (rec)
(let ([pos (car rec)]
[inst (cadr rec)])
(case (car inst)
[(set) (let ([label (cadr inst)])
(let ([addr (let ([p (assq label atable)])
(if p (cadr p) label))])
(vector-set! code-vec pos
`(set ,addr ,(caddr inst)))))]
[(ba bne be bg ble bge bl bpos bneg)
(let ([label (cadr inst)])
(let ([addr (cadr (assq label atable))])
(vector-set! code-vec pos
`(,(car inst) ,addr))))])))
back)
(let ([i (car ls)])
(case (car i)
[(comment)
(loop pos (cdr ls) atable back)]
[(label)
(loop pos (cdr ls) (cons (list (cadr i) (* pos 4)) atable)
back)]
[(set ba bne be bg ble bge bl)
(loop (add1 pos) (cdr ls) atable
(cons (list pos i) back))]
[else
(vector-set! code-vec pos i)
(loop (add1 pos) (cdr ls) atable back)]))))
code-vec)))
(load "bitfield32.ss")
(define emu-code #f)
(define emu-stack #f) (define emu-stack-base (* (expt 2 20) 4))
(define emu-heap #f) (define emu-heap-base (* (expt 2 20) 8))
(define emu-regs (make-vector 8))
(define set-pc! (lambda (n) (vector-set! emu-regs 0 n)))
(define get-pc (lambda () (vector-ref emu-regs 0)))
(define reg-ref (lambda (reg) (vector-ref emu-regs (cadr reg))))
(define reg-set! (lambda (reg o) (vector-set! emu-regs (cadr reg) o)))
(define emu-cc #f)
(define emu-load
(lambda (address)
(cond
[(>= address emu-heap-base)
(vector-ref emu-heap (/ (- address emu-heap-base) 4))]
[(>= address emu-stack-base)
(vector-ref emu-stack (/ (- address emu-stack-base) 4))]
[(vector-ref emu-code (/ address 4))])))
(define emu-store
(lambda (address object)
(cond
[(>= address emu-heap-base)
(vector-set! emu-heap (/ (- address emu-heap-base) 4) object)]
[(>= address emu-stack-base)
(vector-set! emu-stack (/ (- address emu-stack-base) 4) object)]
[(vector-set! emu-code (/ address 4) object)])))
(define emu-load-byte
(lambda (addr)
(let ([subaddr (remainder addr 4)])
(let ([word (emu-load (- addr subaddr))])
(and32 (srl32 word (* (- 3 subaddr) 8))
#b11111111)))))
(define emu-store-byte
(lambda (addr byte)
(let ([subaddr (remainder addr 4)])
(let ([word (emu-load (- addr subaddr))])
(let ([holeyword (and32 (not32 (sll32 #b11111111
(* (- 3 subaddr) 8)))
word)])
(let ([newword
(or32 (sll32 byte (* (- 3 subaddr) 8))
word)])
(emu-store (- addr subaddr) newword)))))))
(define emu-startup
(lambda (program)
(call/cc
(lambda (k)
(set! *reset* k)
(set! emu-code program)
(set! emu-stack (make-vector 1024))
(set! emu-heap (make-vector 4096))
(set-pc! 0)
(reg-set! '(reg 1) emu-stack-base)
(reg-set! '(reg 3) emu-heap-base)
(emu-store emu-stack-base -1)
(emu-run)))))
(define reg-off->address
(lambda (reg-off)
(record-case reg-off
[reg-off (register offset)
(+ (reg-ref register) offset)])))
(define reg-or-lit->value
(lambda (thing)
(if (number? thing)
thing
(reg-ref thing))))
(define emu-run
(lambda ()
(let ([pc (get-pc)])
(when (negative? pc)
(*reset* (emu-rebuild (reg-ref '(reg 4)))))
(let ([inst (emu-load pc)])
(set-pc! (+ pc 4))
(record-case inst
[ld (src dest)
(reg-set! dest (emu-load (reg-off->address src)))]
[st (src dest)
(emu-store (reg-off->address dest) (reg-ref src))]
[ldb (src dest)
(reg-set! dest (emu-load-byte (reg-off->address src)))]
[stb (src dest)
(emu-store-byte (reg-off->address dest) (reg-ref src))]
[set (lit dest)
(reg-set! dest lit)]
[mov (src dest)
(reg-set! dest (reg-ref src))]
[sll (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (sll32 val0 val1)))]
[srl (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (srl32 val0 val1)))]
[sra (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (sra32 val0 val1)))]
[add (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (add32 val0 val1)))]
[sub (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (sub32 val0 val1)))]
[and (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (and32 val0 val1)))]
[or (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (or32 val0 val1)))]
[andn (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (and32 val0 (not32 val1))))]
[smul (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (times32 val0 val1)))]
[sdiv (src0 src1 dest)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(reg-set! dest (quotient32 val0 val1)))]
[cmp (src0 src1)
(let ([val0 (reg-ref src0)]
[val1 (reg-or-lit->value src1)])
(cond
[(= val0 val1) (set! emu-cc 'eq)]
[(less-than32 val0 val1) (set! emu-cc 'lt)]
[else (set! emu-cc 'gt)]))]
[Nop () (void)]
[jmp (reg) (set-pc! (reg-ref reg))]
[ba (addr) (set-pc! addr)]
[be (addr) (if (eq? emu-cc 'eq)
(set-pc! addr))]
[bne (addr) (if (not (eq? emu-cc 'eq))
(set-pc! addr))]
[bl (addr) (if (eq? emu-cc 'lt)
(set-pc! addr))]
[bge (addr) (if (not (eq? emu-cc 'lt))
(set-pc! addr))]
[else
(error 'emu-run "unimplemented instruction: ~s" inst)])
(emu-run)))))
(define emu-rebuild
(lambda (object)
(let ([type (and32 object (- (expt 2 tag-len) 1))])
(cond
[(= type number-tag)
(uncomplement32 (sra32 object tag-len))]
[(= type immed-tag)
(let ([im-type (and32 object (- (expt 2 imm-tag-len) 1))])
(cond
[(= im-type bool-tag) (if (zero? (sra32 object 8)) #f #t)]
[(= im-type null-tag) '()]
[(= im-type char-tag) (integer->char (sra32 object 8))]))]
[(= type pair-tag)
(let ([addr (- object pair-tag)])
(cons (emu-rebuild (emu-load addr))
(emu-rebuild (emu-load (+ addr 4)))))]
[(= type string-tag)
(let* ([addr (- object string-tag)]
[length (emu-load addr)])
(let loop ([end length] [acc '()])
(if (zero? end) (list->string acc)
(loop (- end 1)
(cons (integer->char (emu-load-byte (+ addr end ws -1)))
acc)))))]
[(= type symbol-tag)
(let ([addr (- object symbol-tag)])
(string->symbol (emu-rebuild (emu-load addr))))]
[(= type vector-tag)
(let* ([addr (- object vector-tag)]
[length (emu-load addr)])
(let loop ([end (* length 4)] [acc '()])
(if (zero? end) (list->vector acc)
(loop (- end 4)
(cons (emu-rebuild (emu-load (+ addr end)))
acc)))))]
[(= type closure-tag) '<closure>]
[else '<garbage>]))))