diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt index 33a3832..0b870a3 100644 --- a/js-assembler/assemble.rkt +++ b/js-assembler/assemble.rkt @@ -1,4 +1,9 @@ #lang typed/racket/base + + +;; Assembles the statement stream into JavaScript. + + (require "assemble-structs.rkt" "assemble-helpers.rkt" "assemble-expression.rkt" @@ -20,6 +25,9 @@ (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)) @@ -34,7 +42,7 @@ (define-values (basic-blocks entry-points) (fracture stmts)) (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) @@ -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. -(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]) (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))) @@ -73,53 +87,53 @@ EOF 'ok] [else (let: ([stmt : Statement (first stmts)]) - - (define (next) (write-linked-label-attributes (rest stmts) op)) - - (cond - [(symbol? stmt) - (next)] - [(LinkedLabel? stmt) - (fprintf op "~a.multipleValueReturn = ~a;\n" - (assemble-label (make-Label (LinkedLabel-label stmt))) - (assemble-label (make-Label (LinkedLabel-linked-to stmt)))) - (next)] - [(DebugPrint? stmt) - (next)] - [(AssignImmediateStatement? stmt) - (next)] - [(AssignPrimOpStatement? stmt) - (next)] - [(PerformStatement? stmt) - (next)] - [(TestAndJumpStatement? stmt) - (next)] - [(GotoStatement? stmt) - (next)] - [(PushEnvironment? stmt) - (next)] - [(PopEnvironment? stmt) - (next)] - [(PushImmediateOntoEnvironment? stmt) - (next)] - [(PushControlFrame/Generic? stmt) - (next)] - [(PushControlFrame/Call? stmt) - (next)] - [(PushControlFrame/Prompt? stmt) - (next)] - [(PopControlFrame? stmt) - (next)] - [(Comment? stmt) - (next)]))])) + + (define (next) (write-linked-label-attributes (rest stmts) op)) + + (cond + [(symbol? stmt) + (next)] + [(LinkedLabel? stmt) + (fprintf op "~a.multipleValueReturn = ~a;\n" + (assemble-label (make-Label (LinkedLabel-label stmt))) + (assemble-label (make-Label (LinkedLabel-linked-to stmt)))) + (next)] + [(DebugPrint? stmt) + (next)] + [(AssignImmediateStatement? stmt) + (next)] + [(AssignPrimOpStatement? stmt) + (next)] + [(PerformStatement? stmt) + (next)] + [(TestAndJumpStatement? stmt) + (next)] + [(GotoStatement? stmt) + (next)] + [(PushEnvironment? stmt) + (next)] + [(PopEnvironment? stmt) + (next)] + [(PushImmediateOntoEnvironment? stmt) + (next)] + [(PushControlFrame/Generic? stmt) + (next)] + [(PushControlFrame/Call? stmt) + (next)] + [(PushControlFrame/Prompt? stmt) + (next)] + [(PopControlFrame? stmt) + (next)] + [(Comment? stmt) + (next)]))])) ;; assemble-basic-block: basic-block -> string -(: assemble-basic-block (BasicBlock -> String)) -(define (assemble-basic-block a-basic-block) +(: assemble-basic-block (BasicBlock Blockht -> String)) +(define (assemble-basic-block a-basic-block blockht) (format "var ~a = function(MACHINE){ if(--MACHINE.callsBeforeTrampoline < 0) { 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))) - (string-join (map assemble-statement (BasicBlock-stmts a-basic-block)) + (string-join (assemble-block-statements (BasicBlock-stmts a-basic-block) + blockht) "\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)) ;; Generates the code to assemble a statement. @@ -147,7 +250,7 @@ EOF [(AssignImmediateStatement? stmt) (let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))] [v : OpArg (AssignImmediateStatement-value stmt)]) - (t (assemble-oparg v)))] + (t (assemble-oparg v)))] [(AssignPrimOpStatement? stmt) ((assemble-target (AssignPrimOpStatement-target stmt)) @@ -160,34 +263,34 @@ EOF (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))] + ;; 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) (assemble-jump (GotoStatement-target stmt))] @@ -198,29 +301,29 @@ EOF [(PushControlFrame/Call? stmt) (format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));" (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)]) - (cond - [(symbol? label) - (assemble-label (make-Label label))] - [(LinkedLabel? label) - (assemble-label (make-Label (LinkedLabel-label label)))])))] + (cond + [(symbol? label) + (assemble-label (make-Label label))] + [(LinkedLabel? label) + (assemble-label (make-Label (LinkedLabel-label label)))])))] [(PushControlFrame/Prompt? stmt) ;; fixme: use a different frame structure (format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));" (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)]) - (cond - [(symbol? label) - (assemble-label (make-Label label))] - [(LinkedLabel? label) - (assemble-label (make-Label (LinkedLabel-label label)))])) + (cond + [(symbol? label) + (assemble-label (make-Label label))] + [(LinkedLabel? label) + (assemble-label (make-Label (LinkedLabel-label label)))])) (let: ([tag : (U DefaultContinuationPromptTag OpArg) (PushControlFrame/Prompt-tag stmt)]) - (cond - [(DefaultContinuationPromptTag? tag) - (assemble-default-continuation-prompt-tag)] - [(OpArg? tag) - (assemble-oparg tag)])))] + (cond + [(DefaultContinuationPromptTag? tag) + (assemble-default-continuation-prompt-tag)] + [(OpArg? tag) + (assemble-oparg tag)])))] [(PopControlFrame? stmt) "MACHINE.control.pop();"] @@ -231,21 +334,21 @@ EOF (format "MACHINE.env.push(~a);" (string-join (build-list (PushEnvironment-n stmt) (lambda: ([i : Natural]) - (if (PushEnvironment-unbox? stmt) - "[undefined]" - "undefined"))) + (if (PushEnvironment-unbox? stmt) + "[undefined]" + "undefined"))) ", ")))] [(PopEnvironment? stmt) (let: ([skip : OpArg (PopEnvironment-skip stmt)]) - (cond - [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0)) - (format "MACHINE.env.length = MACHINE.env.length - ~a;" - (assemble-oparg (PopEnvironment-n stmt)))] - [else - (format "MACHINE.env.splice(MACHINE.env.length - (~a + ~a), ~a);" - (assemble-oparg (PopEnvironment-skip stmt)) - (assemble-oparg (PopEnvironment-n stmt)) - (assemble-oparg (PopEnvironment-n stmt)))]))] + (cond + [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0)) + (format "MACHINE.env.length = MACHINE.env.length - ~a;" + (assemble-oparg (PopEnvironment-n stmt)))] + [else + (format "MACHINE.env.splice(MACHINE.env.length - (~a + ~a), ~a);" + (assemble-oparg (PopEnvironment-skip stmt)) + (assemble-oparg (PopEnvironment-n stmt)) + (assemble-oparg (PopEnvironment-n stmt)))]))] [(PushImmediateOntoEnvironment? stmt) (format "MACHINE.env.push(~a);" @@ -254,7 +357,7 @@ EOF (format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)))] [else (assemble-oparg (PushImmediateOntoEnvironment-value stmt))])]) - val-string))] + val-string))] [(Comment? stmt) ;; TODO: maybe comments should be emitted as JavaScript comments. ""])))