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

about to translate branches into real if statements

Browse Source
This commit is contained in:
Danny Yoo 2011-08-05 15:20:14 -04:00
parent 2d62faf794
commit 31d4be5b3f
1 changed files with 206 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

309
js-assembler/assemble.rkt
View File

@ -1,4 +1,9 @@
#lang typed/racket/base #lang typed/racket/base
;; Assembles the statement stream into JavaScript.
(require "assemble-structs.rkt" (require "assemble-structs.rkt"
"assemble-helpers.rkt" "assemble-helpers.rkt"
"assemble-expression.rkt" "assemble-expression.rkt"
@ -20,6 +25,9 @@
(define current-emit-debug-trace? (make-parameter #f)) (define current-emit-debug-trace? (make-parameter #f))
;; Represents a hashtable from symbols to basic blocks
(define-type Blockht (HashTable Symbol BasicBlock))
(: assemble/write-invoke ((Listof Statement) Output-Port -> Void)) (: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
@ -34,7 +42,7 @@
(define-values (basic-blocks entry-points) (fracture stmts)) (define-values (basic-blocks entry-points) (fracture stmts))
(define optimized-basic-blocks (optimize-basic-blocks basic-blocks)) (define optimized-basic-blocks (optimize-basic-blocks basic-blocks))
(write-blocks optimized-basic-blocks op) (write-blocks optimized-basic-blocks entry-points op)
(write-linked-label-attributes stmts op) (write-linked-label-attributes stmts op)
@ -53,12 +61,18 @@ EOF
(: write-blocks ((Listof BasicBlock) Output-Port -> Void)) (: write-blocks ((Listof BasicBlock) (Listof Symbol) Output-Port -> Void))
;; Write out all the basic blocks. ;; Write out all the basic blocks.
(define (write-blocks blocks op) (define (write-blocks blocks entry-points op)
(: blockht : Blockht)
(define blockht (make-hash))
(for ([b blocks])
(hash-set! blockht (BasicBlock-name b) b))
(for ([b blocks]) (for ([b blocks])
(log-debug (format "Emitting code for basic block ~s" (BasicBlock-name b))) (log-debug (format "Emitting code for basic block ~s" (BasicBlock-name b)))
(displayln (assemble-basic-block b) op) (displayln (assemble-basic-block b blockht) op)
(newline op))) (newline op)))
@ -73,53 +87,53 @@ EOF
'ok] 'ok]
[else [else
(let: ([stmt : Statement (first stmts)]) (let: ([stmt : Statement (first stmts)])
(define (next) (write-linked-label-attributes (rest stmts) op)) (define (next) (write-linked-label-attributes (rest stmts) op))
(cond (cond
[(symbol? stmt) [(symbol? stmt)
(next)] (next)]
[(LinkedLabel? stmt) [(LinkedLabel? stmt)
(fprintf op "~a.multipleValueReturn = ~a;\n" (fprintf op "~a.multipleValueReturn = ~a;\n"
(assemble-label (make-Label (LinkedLabel-label stmt))) (assemble-label (make-Label (LinkedLabel-label stmt)))
(assemble-label (make-Label (LinkedLabel-linked-to stmt)))) (assemble-label (make-Label (LinkedLabel-linked-to stmt))))
(next)] (next)]
[(DebugPrint? stmt) [(DebugPrint? stmt)
(next)] (next)]
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(next)] (next)]
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
(next)] (next)]
[(PerformStatement? stmt) [(PerformStatement? stmt)
(next)] (next)]
[(TestAndJumpStatement? stmt) [(TestAndJumpStatement? stmt)
(next)] (next)]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(next)] (next)]
[(PushEnvironment? stmt) [(PushEnvironment? stmt)
(next)] (next)]
[(PopEnvironment? stmt) [(PopEnvironment? stmt)
(next)] (next)]
[(PushImmediateOntoEnvironment? stmt) [(PushImmediateOntoEnvironment? stmt)
(next)] (next)]
[(PushControlFrame/Generic? stmt) [(PushControlFrame/Generic? stmt)
(next)] (next)]
[(PushControlFrame/Call? stmt) [(PushControlFrame/Call? stmt)
(next)] (next)]
[(PushControlFrame/Prompt? stmt) [(PushControlFrame/Prompt? stmt)
(next)] (next)]
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
(next)] (next)]
[(Comment? stmt) [(Comment? stmt)
(next)]))])) (next)]))]))
;; assemble-basic-block: basic-block -> string ;; assemble-basic-block: basic-block -> string
(: assemble-basic-block (BasicBlock -> String)) (: assemble-basic-block (BasicBlock Blockht -> String))
(define (assemble-basic-block a-basic-block) (define (assemble-basic-block a-basic-block blockht)
(format "var ~a = function(MACHINE){ (format "var ~a = function(MACHINE){
if(--MACHINE.callsBeforeTrampoline < 0) { if(--MACHINE.callsBeforeTrampoline < 0) {
throw ~a; throw ~a;
@ -128,10 +142,99 @@ 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 (map assemble-statement (BasicBlock-stmts a-basic-block)) (string-join (assemble-block-statements (BasicBlock-stmts a-basic-block)
blockht)
"\n"))) "\n")))
(: assemble-block-statements ((Listof UnlabeledStatement) Blockht -> (Listof String)))
(define (assemble-block-statements stmts blockht)
(: default (UnlabeledStatement -> (Listof String)))
(define (default stmt)
(cons (assemble-statement stmt)
(assemble-block-statements (rest stmts) blockht)))
(cond [(empty? stmts)
empty]
[else
(define stmt (first stmts))
(cond
[(DebugPrint? stmt)
(default stmt)]
[(AssignImmediateStatement? stmt)
(default stmt)]
[(AssignPrimOpStatement? stmt)
(default stmt)]
[(PerformStatement? stmt)
(default stmt)]
[(TestAndJumpStatement? stmt)
(default stmt)
#;(let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]
[jump : String (assemble-jump
(make-Label (TestAndJumpStatement-label stmt)))])
;; to help localize type checks, we add a type annotation here.
(ann (cond
[(TestFalse? test)
(format "if (~a === false) { ~a }"
(assemble-oparg (TestFalse-operand test))
jump)]
[(TestTrue? test)
(format "if (~a !== false) { ~a }"
(assemble-oparg (TestTrue-operand test))
jump)]
[(TestOne? test)
(format "if (~a === 1) { ~a }"
(assemble-oparg (TestOne-operand test))
jump)]
[(TestZero? test)
(format "if (~a === 0) { ~a }"
(assemble-oparg (TestZero-operand test))
jump)]
[(TestPrimitiveProcedure? test)
(format "if (typeof(~a) === 'function') { ~a }"
(assemble-oparg (TestPrimitiveProcedure-operand test))
jump)]
[(TestClosureArityMismatch? test)
(format "if (! RUNTIME.isArityMatching((~a).racketArity, ~a)) { ~a }"
(assemble-oparg (TestClosureArityMismatch-closure test))
(assemble-oparg (TestClosureArityMismatch-n test))
jump)])
String))]
[(GotoStatement? stmt)
(default stmt)]
[(PushControlFrame/Generic? stmt)
(default stmt)]
[(PushControlFrame/Call? stmt)
(default stmt)]
[(PushControlFrame/Prompt? stmt)
(default stmt)]
[(PopControlFrame? stmt)
(default stmt)]
[(PushEnvironment? stmt)
(default stmt)]
[(PopEnvironment? stmt)
(default stmt)]
[(PushImmediateOntoEnvironment? stmt)
(default stmt)]
[(Comment? stmt)
(default stmt)])]))
(: assemble-statement (UnlabeledStatement -> String)) (: assemble-statement (UnlabeledStatement -> String))
;; Generates the code to assemble a statement. ;; Generates the code to assemble a statement.
@ -147,7 +250,7 @@ EOF
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))] (let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))]
[v : OpArg (AssignImmediateStatement-value stmt)]) [v : OpArg (AssignImmediateStatement-value stmt)])
(t (assemble-oparg v)))] (t (assemble-oparg v)))]
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
((assemble-target (AssignPrimOpStatement-target stmt)) ((assemble-target (AssignPrimOpStatement-target stmt))
@ -160,34 +263,34 @@ EOF
(let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)] (let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]
[jump : String (assemble-jump [jump : String (assemble-jump
(make-Label (TestAndJumpStatement-label stmt)))]) (make-Label (TestAndJumpStatement-label stmt)))])
;; to help localize type checks, we add a type annotation here. ;; to help localize type checks, we add a type annotation here.
(ann (cond (ann (cond
[(TestFalse? test) [(TestFalse? test)
(format "if (~a === false) { ~a }" (format "if (~a === false) { ~a }"
(assemble-oparg (TestFalse-operand test)) (assemble-oparg (TestFalse-operand test))
jump)] jump)]
[(TestTrue? test) [(TestTrue? test)
(format "if (~a !== false) { ~a }" (format "if (~a !== false) { ~a }"
(assemble-oparg (TestTrue-operand test)) (assemble-oparg (TestTrue-operand test))
jump)] jump)]
[(TestOne? test) [(TestOne? test)
(format "if (~a === 1) { ~a }" (format "if (~a === 1) { ~a }"
(assemble-oparg (TestOne-operand test)) (assemble-oparg (TestOne-operand test))
jump)] jump)]
[(TestZero? test) [(TestZero? test)
(format "if (~a === 0) { ~a }" (format "if (~a === 0) { ~a }"
(assemble-oparg (TestZero-operand test)) (assemble-oparg (TestZero-operand test))
jump)] jump)]
[(TestPrimitiveProcedure? test) [(TestPrimitiveProcedure? test)
(format "if (typeof(~a) === 'function') { ~a }" (format "if (typeof(~a) === 'function') { ~a }"
(assemble-oparg (TestPrimitiveProcedure-operand test)) (assemble-oparg (TestPrimitiveProcedure-operand test))
jump)] jump)]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if (! RUNTIME.isArityMatching((~a).racketArity, ~a)) { ~a }" (format "if (! RUNTIME.isArityMatching((~a).racketArity, ~a)) { ~a }"
(assemble-oparg (TestClosureArityMismatch-closure test)) (assemble-oparg (TestClosureArityMismatch-closure test))
(assemble-oparg (TestClosureArityMismatch-n test)) (assemble-oparg (TestClosureArityMismatch-n test))
jump)]) jump)])
String))] String))]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(assemble-jump (GotoStatement-target stmt))] (assemble-jump (GotoStatement-target stmt))]
@ -198,29 +301,29 @@ EOF
[(PushControlFrame/Call? stmt) [(PushControlFrame/Call? stmt)
(format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));" (format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)]) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
(cond (cond
[(symbol? label) [(symbol? label)
(assemble-label (make-Label label))] (assemble-label (make-Label label))]
[(LinkedLabel? label) [(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))])))] (assemble-label (make-Label (LinkedLabel-label label)))])))]
[(PushControlFrame/Prompt? stmt) [(PushControlFrame/Prompt? stmt)
;; fixme: use a different frame structure ;; fixme: use a different frame structure
(format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));" (format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)]) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
(cond (cond
[(symbol? label) [(symbol? label)
(assemble-label (make-Label label))] (assemble-label (make-Label label))]
[(LinkedLabel? label) [(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))])) (assemble-label (make-Label (LinkedLabel-label label)))]))
(let: ([tag : (U DefaultContinuationPromptTag OpArg) (let: ([tag : (U DefaultContinuationPromptTag OpArg)
(PushControlFrame/Prompt-tag stmt)]) (PushControlFrame/Prompt-tag stmt)])
(cond (cond
[(DefaultContinuationPromptTag? tag) [(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)] (assemble-default-continuation-prompt-tag)]
[(OpArg? tag) [(OpArg? tag)
(assemble-oparg tag)])))] (assemble-oparg tag)])))]
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
"MACHINE.control.pop();"] "MACHINE.control.pop();"]
@ -231,21 +334,21 @@ EOF
(format "MACHINE.env.push(~a);" (string-join (format "MACHINE.env.push(~a);" (string-join
(build-list (PushEnvironment-n stmt) (build-list (PushEnvironment-n stmt)
(lambda: ([i : Natural]) (lambda: ([i : Natural])
(if (PushEnvironment-unbox? stmt) (if (PushEnvironment-unbox? stmt)
"[undefined]" "[undefined]"
"undefined"))) "undefined")))
", ")))] ", ")))]
[(PopEnvironment? stmt) [(PopEnvironment? stmt)
(let: ([skip : OpArg (PopEnvironment-skip stmt)]) (let: ([skip : OpArg (PopEnvironment-skip stmt)])
(cond (cond
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0)) [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
(format "MACHINE.env.length = MACHINE.env.length - ~a;" (format "MACHINE.env.length = MACHINE.env.length - ~a;"
(assemble-oparg (PopEnvironment-n stmt)))] (assemble-oparg (PopEnvironment-n stmt)))]
[else [else
(format "MACHINE.env.splice(MACHINE.env.length - (~a + ~a), ~a);" (format "MACHINE.env.splice(MACHINE.env.length - (~a + ~a), ~a);"
(assemble-oparg (PopEnvironment-skip stmt)) (assemble-oparg (PopEnvironment-skip stmt))
(assemble-oparg (PopEnvironment-n stmt)) (assemble-oparg (PopEnvironment-n stmt))
(assemble-oparg (PopEnvironment-n stmt)))]))] (assemble-oparg (PopEnvironment-n stmt)))]))]
[(PushImmediateOntoEnvironment? stmt) [(PushImmediateOntoEnvironment? stmt)
(format "MACHINE.env.push(~a);" (format "MACHINE.env.push(~a);"
@ -254,7 +357,7 @@ EOF
(format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)))] (format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)))]
[else [else
(assemble-oparg (PushImmediateOntoEnvironment-value stmt))])]) (assemble-oparg (PushImmediateOntoEnvironment-value stmt))])])
val-string))] val-string))]
[(Comment? stmt) [(Comment? stmt)
;; TODO: maybe comments should be emitted as JavaScript comments. ;; TODO: maybe comments should be emitted as JavaScript comments.
""]))) ""])))