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

getting into loops; this might not be a good sign...

Browse Source
This commit is contained in:
Danny Yoo 2011-08-05 15:49:18 -04:00
parent 63cfe79d76
commit f0c65d761c
1 changed files with 37 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
js-assembler/assemble.rkt
View File

@ -62,7 +62,7 @@ EOF
(: write-blocks ((Listof BasicBlock) (Listof Symbol) Output-Port -> Void)) (: write-blocks ((Listof BasicBlock) (Listof Symbol) Output-Port -> Void))
;; Write out all the basic blocks. ;; Write out all the basic blocks associated to an entry point.
(define (write-blocks blocks entry-points op) (define (write-blocks blocks entry-points op)
(: blockht : Blockht) (: blockht : Blockht)
(define blockht (make-hash)) (define blockht (make-hash))
@ -70,9 +70,12 @@ EOF
(for ([b blocks]) (for ([b blocks])
(hash-set! blockht (BasicBlock-name b) b)) (hash-set! blockht (BasicBlock-name b) b))
(for ([b blocks]) (for ([s entry-points])
(log-debug (format "Emitting code for basic block ~s" (BasicBlock-name b))) (log-debug (format "Emitting code for basic block ~s" s))
(displayln (assemble-basic-block b blockht) op) (displayln (assemble-basic-block (hash-ref blockht s)
blockht
entry-points)
op)
(newline op))) (newline op)))
@ -132,8 +135,8 @@ EOF
;; assemble-basic-block: basic-block -> string ;; assemble-basic-block: basic-block -> string
(: assemble-basic-block (BasicBlock Blockht -> String)) (: assemble-basic-block (BasicBlock Blockht (Listof Symbol) -> String))
(define (assemble-basic-block a-basic-block blockht) (define (assemble-basic-block a-basic-block blockht entry-points)
(format "var ~a = function(MACHINE){ (format "var ~a = function(MACHINE){
if(--MACHINE.callsBeforeTrampoline < 0) { if(--MACHINE.callsBeforeTrampoline < 0) {
throw ~a; throw ~a;
@ -143,17 +146,20 @@ EOF
(assemble-label (make-Label (BasicBlock-name a-basic-block))) (assemble-label (make-Label (BasicBlock-name a-basic-block)))
(assemble-label (make-Label (BasicBlock-name a-basic-block))) (assemble-label (make-Label (BasicBlock-name a-basic-block)))
(string-join (assemble-block-statements (BasicBlock-stmts a-basic-block) (string-join (assemble-block-statements (BasicBlock-stmts a-basic-block)
blockht) blockht
entry-points)
"\n"))) "\n")))
(: assemble-block-statements ((Listof UnlabeledStatement) Blockht -> (Listof String))) (: assemble-block-statements ((Listof UnlabeledStatement) Blockht (Listof Symbol) -> (Listof String)))
(define (assemble-block-statements stmts blockht) (define (assemble-block-statements stmts blockht entry-points)
(: default (UnlabeledStatement -> (Listof String))) (: default (UnlabeledStatement -> (Listof String)))
(define (default stmt) (define (default stmt)
(cons (assemble-statement stmt) (cons (assemble-statement stmt)
(assemble-block-statements (rest stmts) blockht))) (assemble-block-statements (rest stmts)
blockht
entry-points)))
(cond [(empty? stmts) (cond [(empty? stmts)
empty] empty]
@ -202,13 +208,31 @@ EOF
"{" "{"
,@(assemble-block-statements (BasicBlock-stmts ,@(assemble-block-statements (BasicBlock-stmts
(hash-ref blockht (TestAndJumpStatement-label stmt))) (hash-ref blockht (TestAndJumpStatement-label stmt)))
blockht) blockht
entry-points)
"} else {" "} else {"
,@(assemble-block-statements (rest stmts) blockht) ,@(assemble-block-statements (rest stmts) blockht entry-points)
"}")] "}")]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(default stmt)] (define target (GotoStatement-target stmt))
(cond
[(Label? target)
(cond
[(member (Label-name target) entry-points)
(default stmt)]
[else
(assemble-block-statements (BasicBlock-stmts
(hash-ref blockht (Label-name target)))
blockht
entry-points)])]
[(Reg? target)
(default stmt)]
[(ModuleEntry? target)
(default stmt)]
[(CompiledProcedureEntry? target)
(default stmt)])]
[(PushControlFrame/Generic? stmt) [(PushControlFrame/Generic? stmt)
(default stmt)] (default stmt)]