suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

trying to speed up the simulator a bit

Browse Source
This commit is contained in:
Danny Yoo 2011-03-14 19:15:42 -04:00
parent 7ce499d2b3
commit c783850732
4 changed files with 40 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
assemble.rkt
View File

@ -336,6 +336,11 @@ EOF
(format "MACHINE.env[MACHINE.env.length - 1 - ~a]"
(EnvWholePrefixReference-depth ref))]))
(: assemble-display-name ((U Symbol False) -> String))
(define (assemble-display-name symbol-or-string)
(if (symbol? symbol-or-string)
(format "~s" (symbol->string symbol-or-string))
"false"))
(: assemble-op-expression (PrimitiveOperator -> String))
(define (assemble-op-expression op)
@ -344,7 +349,7 @@ EOF
"MACHINE.proc.label"]
[(MakeCompiledProcedure? op)
(format "new Closure(~a, ~a, [~a], ~s)"
(format "new Closure(~a, ~a, [~a], ~a)"
(MakeCompiledProcedure-label op)
(MakeCompiledProcedure-arity op)
(string-join (map assemble-env-reference/closure-capture
@ -354,7 +359,7 @@ EOF
;; during install-closure-values.
(reverse (MakeCompiledProcedure-closed-vals op)))
", ")
(symbol->string (MakeCompiledProcedure-display-name op)))]
(assemble-display-name (MakeCompiledProcedure-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(format "MACHINE.proc(~a, ~a)"

3
simulator-structs.rkt
View File

@ -42,6 +42,9 @@
;; other metrics for debugging
[stack-size : Natural]
;; compute position from label
[jump-table : (HashTable Symbol Natural)]
)
#:transparent
#:mutable)

39
simulator.rkt
View File

@ -30,7 +30,15 @@
(: new-machine ((Listof Statement) -> machine))
(define (new-machine program-text)
(make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0))
(let: ([m : machine (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0
((inst make-hash Symbol Natural)))])
(let: loop : Void ([i : Natural 0])
(when (< i (vector-length (machine-text m)))
(let: ([stmt : Statement (vector-ref (machine-text m) i)])
(when (symbol? stmt)
(hash-set! (machine-jump-table m) stmt i))
(loop (add1 i)))))
m))
@ -404,7 +412,7 @@
(define (current-instruction m)
(match m
[(struct machine (val proc env control pc text
stack-size))
stack-size jump-table))
(vector-ref text pc)]))
@ -424,7 +432,7 @@
(: env-push! (machine SlotValue -> 'ok))
(define (env-push! m v)
(match m
[(struct machine (val proc env control pc text stack-size))
[(struct machine (val proc env control pc text stack-size jump-table))
(set-machine-env! m (cons v env))
(set-machine-stack-size! m (add1 stack-size))
'ok]))
@ -432,7 +440,7 @@
(: env-push-many! (machine (Listof SlotValue) -> 'ok))
(define (env-push-many! m vs)
(match m
[(struct machine (val proc env control pc text stack-size))
[(struct machine (val proc env control pc text stack-size jump-table))
(set-machine-env! m (append vs env))
(set-machine-stack-size! m (+ stack-size (length vs)))
'ok]))
@ -441,13 +449,13 @@
(: env-ref (machine Natural -> SlotValue))
(define (env-ref m i)
(match m
[(struct machine (val proc env control pc text stack-size))
[(struct machine (val proc env control pc text stack-size jump-table))
(list-ref env i)]))
(: env-mutate! (machine Natural SlotValue -> 'ok))
(define (env-mutate! m i v)
(match m
[(struct machine (val proc env control pc text stack-size))
[(struct machine (val proc env control pc text stack-size jump-table))
(set-machine-env! m (list-replace env i v))
'ok]))
@ -465,7 +473,7 @@
(: env-pop! (machine Natural Natural -> 'ok))
(define (env-pop! m n skip)
(match m
[(struct machine (val proc env control pc text stack-size))
[(struct machine (val proc env control pc text stack-size jump-table))
(set-machine-env! m (append (take env skip)
(drop env (+ skip n))))
(set-machine-stack-size! m (ensure-natural (- stack-size n)))
@ -475,7 +483,7 @@
(: control-push! (machine frame -> 'ok))
(define (control-push! m a-frame)
(match m
[(struct machine (val proc env control pc text stack-size))
[(struct machine (val proc env control pc text stack-size jump-table))
(set-machine-control! m (cons a-frame control))
'ok]))
@ -483,7 +491,7 @@
(: control-pop! (machine -> 'ok))
(define (control-pop! m)
(match m
[(struct machine (val proc env control pc text stack-size))
[(struct machine (val proc env control pc text stack-size jump-table))
(set-machine-control! m (rest control))
'ok]))
@ -500,21 +508,12 @@
;; Jumps directly to the instruction at the given label.
(define (jump! m l)
(match m
[(struct machine (val proc env control pc text stack-size))
(set-machine-pc! m (vector-find text l))
[(struct machine (val proc env control pc text stack-size jump-table))
(set-machine-pc! m (hash-ref jump-table l))
'ok]))
(: vector-find (All (A) (Vectorof A) A -> Natural))
(define (vector-find vec x)
(let: loop : Natural ([i : Natural 0])
(cond
[(eq? (vector-ref vec i) x)
i]
[else
(loop (add1 i))])))
(: toplevel-mutate! (toplevel Natural PrimitiveValue -> 'ok))
(define (toplevel-mutate! a-top index v)

17
test-assemble.rkt
View File

@ -177,7 +177,7 @@
'closureStart
(make-GotoStatement (make-Label 'afterLambda))
'afterLambda
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '())))
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0 '() 'closureStart)))
"MACHINE.val.displayName")
"closureStart")
@ -194,7 +194,8 @@
(make-Const "world"))
(make-AssignPrimOpStatement 'val (make-MakeCompiledProcedure 'closureStart 0
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f)))))
(make-EnvLexicalReference 1 #f))
'closureStart)))
"MACHINE.val.closedVals[1] + ',' + MACHINE.val.closedVals[0]")
"hello,world")
@ -213,7 +214,8 @@
(make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))))
(make-EnvLexicalReference 1 #f))
'closureStart))
(make-PopEnvironment 2 0)
(make-GotoStatement (make-Label 'closureStart))
'theEnd)
@ -237,7 +239,8 @@
(make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 0
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))))
(make-EnvLexicalReference 1 #f))
'closureStart))
(make-PopEnvironment 2 0)
(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)))
"typeof(MACHINE.val) + ',' + (MACHINE.val === MACHINE.proc.label)")
@ -259,7 +262,8 @@
(make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))))
(make-EnvLexicalReference 1 #f))
'closureStart))
(make-PopEnvironment 2 0)
(make-PerformStatement (make-CheckClosureArity! 5)))))
@ -281,7 +285,8 @@
(make-Const "world"))
(make-AssignPrimOpStatement 'proc (make-MakeCompiledProcedure 'closureStart 5
(list (make-EnvLexicalReference 0 #f)
(make-EnvLexicalReference 1 #f))))
(make-EnvLexicalReference 1 #f))
'closureStart))
(make-PopEnvironment 2 0)
(make-PerformStatement (make-CheckClosureArity! 1)))))
(error 'expected-failure))