Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 859cb5ecd8
Fetching contributors…

Cannot retrieve contributors at this time

446 lines (370 sloc) 13.042 kb
(require (fs "fs")
(compiler "./compiler"))
;; main functions
(define (make-machine regs ops controller)
(let ((machine (make-new-machine)))
(for-each (lambda (reg)
(machine.allocate-register reg))
regs)
(machine.install-operations ops)
(machine.install-instruction-sequence (assemble controller machine))
machine))
;; registers
(define (make-register)
(let ((contents '_unassigned_))
{:get (lambda () contents)
:set! (lambda (val) (set! contents val))}))
;; stack
(define (make-stack)
(let ((s '()))
{:push (lambda (x)
(set! s (cons x s)))
:pop! (lambda ()
(if (null? s)
(throw "pop: empty stack")
(let ((top (car s)))
(set! s (cdr s))
top)))
:initialize (lambda () (set! s '() 'done))}))
;; machine
(define (make-new-machine)
(let ((pc (make-register))
(flag (make-register))
(stack (make-stack))
(instruction-sequence '())
(paused #f)
(stack-ptr 0))
(let ((ops {:initialize-stack stack.initialize})
(reg-table {:pc pc :flag flag}))
(define (allocate-register name)
(if (list-find (keys reg-table) name)
(throw (str "register already defined: " name))
(dict-put! reg-table name (make-register))))
(define (lookup-register name)
(if (list-find (keys reg-table) name)
(dict-ref reg-table name)
(throw (str "unknown register: " name))))
(define (pause) (set! paused #t))
(define (print-registers)
(for-each (lambda (name)
(if (and (not (== name 'pc))
(not (== name 'continue)))
(let ((reg (lookup-register name)))
(console.log (+ (symbol->string name)
": " (util.inspect (reg.get)))))))
(keys reg-table)))
(define (execute)
(let loop ()
(let ((insts (pc.get)))
(if (null? insts)
'done
(let ((inst (car insts)))
(if (not paused)
(let ((proc (instruction-exec-proc inst)))
(if proc
(proc)
(throw (str "invalid exec proc: " proc)))
(loop))))))))
{:start (lambda () (pc.set! instruction-sequence) (execute))
:install-instruction-sequence (lambda (seq)
(set! instruction-sequence seq))
:allocate-register allocate-register
:get-register lookup-register
:install-operations (lambda (dct) (set! ops (dict-merge ops dct)))
:stack (lambda () stack)
:operations (lambda () ops)
:registers (lambda () (keys reg-table))
:print-registers print-registers
:pause pause
:proceed (lambda ()
(set! paused #f)
(execute))
:on-input (lambda (txt)
(let ((exp (instruction-text (car (pc.get)))))
(if (eq? (car exp) 'read-into-reg)
(let ((reg (lookup-register (cadr exp))))
(reg.set! (read txt))))
;; stop stdin and unpause the machine
(advance-pc pc)
(stop-stdin)
(set! paused #f)
(execute)))})))
(define (get-register-contents machine name)
((dict-ref (machine.get-register name) 'get)))
(define (set-register-contents! machine name val)
((dict-ref (machine.get-register name) 'set!) val))
;; assembler
(define (assemble controller machine)
(extract-labels controller
(lambda (insts labels)
(update-insts! insts labels machine)
insts)))
(define (extract-labels text receive)
(if (null? text)
(receive '() '())
(extract-labels (cdr text)
(lambda (insts labels)
(let ((next-inst (car text)))
(if (symbol? next-inst)
(receive insts
(cons (make-label-entry next-inst
insts)
labels))
(receive (cons (make-instruction next-inst)
insts)
labels)))))))
(define (update-insts! insts labels machine)
(let ((pc (machine.get-register 'pc))
(flag (machine.get-register 'flag))
(stack (machine.stack))
(ops (machine.operations)))
(for-each
(lambda (inst)
(set-instruction-exec-proc!
inst
(make-execution-procedure
(instruction-text inst) labels machine
pc flag stack ops)))
insts)
(for-each
(lambda (label)
(let ((i 0))
(for-each (lambda (inst)
(set-instruction-label! inst
(label-entry-name label))
(set-instruction-line-number! inst i)
(set! i (+ i 1)))
(label-insts label))))
labels)))
;; instructions
(define (make-instruction text)
[text '() #f #f])
(define (instruction-text inst)
(vector-ref inst 0))
(define (instruction-exec-proc inst)
(vector-ref inst 1))
(define (instruction-label inst)
(vector-ref inst 2))
(define (instruction-line-number inst)
(vector-ref inst 3))
(define (set-instruction-exec-proc! inst proc)
(vector-put! inst 1 proc))
(define (set-instruction-label! inst label)
(vector-put! inst 2 label))
(define (set-instruction-line-number! inst n)
(vector-put! inst 3 n))
;; labels
(define (make-label-entry label insts)
[label insts])
(define (label-entry-name label)
(vector-ref label 0))
(define (label-insts label)
(vector-ref label 1))
(define (lookup-label labels name)
(let ((lst (list-find labels name
(lambda (v) (vector-ref v 0)))))
(if lst
(vector-ref (car lst) 1)
(throw (str "undefined label: " name)))))
;; execution procedures
(define (advance-pc pc)
(pc.set! (cdr (pc.get))))
(define (make-execution-procedure inst labels machine
pc flag stack ops)
(let ((top (car inst)))
(cond
((== top 'assign) (make-assign inst machine labels ops pc))
((== top 'test) (make-test inst machine labels ops flag pc))
((== top 'branch) (make-branch inst machine labels flag pc))
((== top 'goto) (make-goto inst machine labels pc))
((== top 'save) (make-save inst machine stack pc))
((== top 'restore) (make-restore inst machine stack pc))
((== top 'perform) (make-perform inst machine labels ops pc))
((== top 'read-into-reg) (make-read inst machine pc))
((== top 'break) (make-break machine pc))
((== top 'next) (make-next machine pc)))))
(define (make-assign inst machine labels ops pc)
(let ((target (machine.get-register (cadr inst)))
(expr (cddr inst)))
(let ((value-proc
(if (operation-exp? expr)
(make-operation-exp expr machine labels ops)
(make-primitive-exp (car expr) machine labels))))
(lambda ()
(target.set! (value-proc))
(advance-pc pc)))))
(define (make-test inst machine labels ops flag pc)
(let ((condition (cdr inst)))
(if (operation-exp? condition)
(let ((condition-proc
(make-operation-exp condition machine labels ops)))
(lambda ()
(flag.set! (condition-proc))
(advance-pc pc)))
(throw (str "bad test instruction:" inst)))))
(define (make-branch inst machine labels flag pc)
(let ((dest (cadr inst)))
(if (label-exp? dest)
(let ((insts (lookup-label labels (label-exp-label dest))))
(lambda ()
(if (flag.get)
(pc.set! insts)
(advance-pc pc))))
(throw (str "bad branch instruction: " inst)))))
(define (make-goto inst machine labels pc)
(let ((dest (cadr inst)))
(cond
((label-exp? dest)
(let ((insts (lookup-label labels
(label-exp-label dest))))
(lambda () (pc.set! insts))))
((register-exp? dest)
(let ((reg (machine.get-register (register-exp-reg dest))))
(lambda () (pc.set! (reg.get)))))
(else
(throw (str "bad goto instruction: " inst))))))
(define (make-save inst machine stack pc)
(let ((reg (machine.get-register (cadr inst))))
(lambda ()
(stack.push (reg.get))
(advance-pc pc))))
(define (make-restore inst machine stack pc)
(let ((reg (machine.get-register (cadr inst))))
(lambda ()
(reg.set! (stack.pop!))
(advance-pc pc))))
(define (make-perform inst machine labels ops pc)
(let ((action (cdr inst)))
(if (operation-exp? action)
(let ((action-proc
(make-operation-exp action machine labels ops)))
(lambda ()
(action-proc)
(advance-pc pc)))
(throw (str "bad perform instruction: " inst)))))
(define (make-read inst machine pc)
(let ((reg (machine.get-register (cadr inst))))
(lambda ()
(start-stdin 'repl)
(machine.pause))))
(define (make-break machine pc)
(lambda ()
(advance-pc pc)
(start-stdin 'break)
(println (str "break: " (get-register-contents machine 'exp)))
(machine.pause)))
(define (make-next machine pc)
(lambda ()
(advance-pc pc)
(machine.pause)
(setTimeout (lambda () (machine.proceed)) 1)))
(define (make-primitive-exp exp machine labels)
(cond
((const-exp? exp)
(let ((c (cadr exp)))
(lambda () c)))
((label-exp? exp)
(let ((insts (lookup-label labels (cadr exp))))
(lambda () insts)))
((register-exp? exp)
(let ((r (machine.get-register (cadr exp))))
(lambda () (r.get))))
(else
(throw (str "unknown expression type: " exp)))))
(define (label-exp? exp)
(and (list? exp)
(== (car exp) 'label)))
(define (label-exp-label exp)
(cadr exp))
(define (register-exp? exp)
(and (list? exp)
(== (car exp) 'reg)))
(define (register-exp-reg exp)
(cadr exp))
(define (const-exp? exp)
(and (list? exp)
(== (car exp) 'const)))
(define (const-exp-value exp)
(cadr exp))
(define (make-operation-exp exp machine labels ops)
(let ((op (lookup-prim (cadar exp) ops))
(aprocs (map (lambda (e)
(make-primitive-exp e machine labels))
(cdr exp))))
(lambda ()
(apply op (map (lambda (p) (p)) aprocs)))))
(define (operation-exp? exp)
(and (list? exp)
(eq? (car (car exp)) 'op)))
(define (lookup-prim sym ops)
(let ((prim (dict-ref ops sym)))
(if (not prim)
(throw (str "unknown operation: " sym)))
prim))
;; main
(define (prompt-for-input msg)
(util.print msg))
;; node.js code
(define stdin-mode #f)
(define (start-stdin mode)
(process.stdin.resume)
(set! stdin-mode mode))
(define (stop-stdin)
(process.stdin.pause))
(process.stdin.on
"data"
(lambda (txt)
(let ((txt (+ txt "")))
(cond
((= stdin-mode 'repl) (on-repl-input txt))
((= stdin-mode 'break) (on-break-input txt))))))
(process.stdin.pause)
(define (prompt-read)
(process.stdin.resume))
(define (continue-machine)
(process.stdin.pause)
(current-machine.proceed))
;; end node.js code
;; debugger
(define (inspect-var v)
(cond
((compound-procedure? v)
(let ((s (inspect `(lambda () ,@(procedure-body v)) #t)))
(if (< (vector-length s) 61)
s
(str (vector-slice s 0 60) "...)"))))
((primitive-procedure? v)
"<native-function>")
(else (inspect v))))
(define (inspect-environment)
(let ((frame (first-frame
(get-register-contents current-machine 'env))))
(fold
(lambda (k acc)
(let ((v (dict-ref frame k))
(v (inspect-var v)))
(+ acc (str k ": " v "\n"))))
""
(keys frame))))
(define (debugger-handle txt)
(let ((txt (txt.trim)))
(cond
((= txt "v")
(println (inspect-environment)))
(else
(continue-machine)))))
;; main
(define current-machine #f)
(define (on-repl-input txt) (current-machine.on-input txt))
(define on-break-input debugger-handle)
(define (feed-asm src)
(let ((machine (make-machine
'(env proc val arg1 continue input)
compiler.ops
src)))
(set-register-contents! machine 'env compiler.global-environment)
(set! current-machine machine)
machine))
(set! module.exports {:feed-asm feed-asm
:result (lambda ()
(get-register-contents current-machine 'val))})
Jump to Line
Something went wrong with that request. Please try again.