threading state about all the basic blocks throughout assembly, so we can do some tricks.
This commit is contained in:
Danny Yoo
parent
3c6439ab26
commit
f2c3dc3fe1
|
|
@ -10,15 +10,16 @@
|
|||
|
||||
|
||||
|
||||
(: assemble-op-expression (PrimitiveOperator -> String))
|
||||
(define (assemble-op-expression op)
|
||||
(: assemble-op-expression (PrimitiveOperator Blockht -> String))
|
||||
(define (assemble-op-expression op blockht)
|
||||
(cond
|
||||
[(GetCompiledProcedureEntry? op)
|
||||
"M.p.label"]
|
||||
|
||||
[(MakeCompiledProcedure? op)
|
||||
(format "new RT.Closure(~a,~a,[~a],~a)"
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label op)))
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label op))
|
||||
blockht)
|
||||
(assemble-arity (MakeCompiledProcedure-arity op))
|
||||
(string-join (map
|
||||
assemble-env-reference/closure-capture
|
||||
|
|
@ -32,7 +33,8 @@
|
|||
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(format "new RT.Closure(~a,~a,undefined,~a)"
|
||||
(assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
|
||||
(assemble-label (make-Label (MakeCompiledProcedureShell-label op))
|
||||
blockht)
|
||||
(assemble-arity (MakeCompiledProcedureShell-arity op))
|
||||
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
|
||||
|
||||
|
|
@ -48,7 +50,7 @@
|
|||
(cond [(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag)])))]
|
||||
(assemble-oparg tag blockht)])))]
|
||||
|
||||
|
||||
[(MakeBoxedEnvironmentValue? op)
|
||||
|
|
@ -56,4 +58,4 @@
|
|||
(add1 (MakeBoxedEnvironmentValue-depth op)))]
|
||||
|
||||
[(CallKernelPrimitiveProcedure? op)
|
||||
(open-code-kernel-primitive-procedure op)]))
|
||||
(open-code-kernel-primitive-procedure op blockht)]))
|
||||
|
|
@ -4,8 +4,13 @@
|
|||
"../compiler/expression-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../compiler/arity-structs.rkt"
|
||||
"assemble-structs.rkt"
|
||||
racket/list
|
||||
racket/string)
|
||||
racket/string
|
||||
racket/match)
|
||||
|
||||
|
||||
|
||||
|
||||
(provide assemble-oparg
|
||||
assemble-target
|
||||
|
|
@ -22,19 +27,21 @@
|
|||
assemble-jump
|
||||
assemble-display-name
|
||||
assemble-location
|
||||
assemble-numeric-constant)
|
||||
assemble-numeric-constant
|
||||
|
||||
block-looks-like-context-expected-values?)
|
||||
|
||||
(require/typed typed/racket/base
|
||||
[regexp-split (Regexp String -> (Listof String))])
|
||||
|
||||
|
||||
(: assemble-oparg (OpArg -> String))
|
||||
(define (assemble-oparg v)
|
||||
(: assemble-oparg (OpArg Blockht -> String))
|
||||
(define (assemble-oparg v blockht)
|
||||
(cond
|
||||
[(Reg? v)
|
||||
(assemble-reg v)]
|
||||
[(Label? v)
|
||||
(assemble-label v)]
|
||||
(assemble-label v blockht)]
|
||||
[(Const? v)
|
||||
(assemble-const v)]
|
||||
[(EnvLexicalReference? v)
|
||||
|
|
@ -44,7 +51,7 @@
|
|||
[(EnvWholePrefixReference? v)
|
||||
(assemble-whole-prefix-reference v)]
|
||||
[(SubtractArg? v)
|
||||
(assemble-subtractarg v)]
|
||||
(assemble-subtractarg v blockht)]
|
||||
[(ControlStackLabel? v)
|
||||
(assemble-control-stack-label v)]
|
||||
[(ControlStackLabel/MultipleValueReturn? v)
|
||||
|
|
@ -52,9 +59,9 @@
|
|||
[(ControlFrameTemporary? v)
|
||||
(assemble-control-frame-temporary v)]
|
||||
[(CompiledProcedureEntry? v)
|
||||
(assemble-compiled-procedure-entry v)]
|
||||
(assemble-compiled-procedure-entry v blockht)]
|
||||
[(CompiledProcedureClosureReference? v)
|
||||
(assemble-compiled-procedure-closure-reference v)]
|
||||
(assemble-compiled-procedure-closure-reference v blockht)]
|
||||
[(PrimitiveKernelValue? v)
|
||||
(assemble-primitive-kernel-value v)]
|
||||
[(ModuleEntry? v)
|
||||
|
|
@ -69,6 +76,8 @@
|
|||
|
||||
|
||||
|
||||
|
||||
|
||||
(: assemble-target (Target -> (String -> String)))
|
||||
(define (assemble-target target)
|
||||
(cond
|
||||
|
|
@ -287,8 +296,8 @@
|
|||
|
||||
|
||||
|
||||
(: assemble-label (Label -> String))
|
||||
(define (assemble-label a-label)
|
||||
(: assemble-label (Label Blockht -> String))
|
||||
(define (assemble-label a-label Blockht)
|
||||
(let ([chunks
|
||||
(regexp-split #rx"[^a-zA-Z0-9]+"
|
||||
(symbol->string (Label-name a-label)))])
|
||||
|
|
@ -304,11 +313,11 @@
|
|||
|
||||
|
||||
|
||||
(: assemble-subtractarg (SubtractArg -> String))
|
||||
(define (assemble-subtractarg s)
|
||||
(: assemble-subtractarg (SubtractArg Blockht -> String))
|
||||
(define (assemble-subtractarg s blockht)
|
||||
(format "(~a-~a)"
|
||||
(assemble-oparg (SubtractArg-lhs s))
|
||||
(assemble-oparg (SubtractArg-rhs s))))
|
||||
(assemble-oparg (SubtractArg-lhs s) blockht)
|
||||
(assemble-oparg (SubtractArg-rhs s) blockht)))
|
||||
|
||||
|
||||
(: assemble-control-stack-label (ControlStackLabel -> String))
|
||||
|
|
@ -322,17 +331,18 @@
|
|||
|
||||
|
||||
|
||||
(: assemble-compiled-procedure-entry (CompiledProcedureEntry -> String))
|
||||
(define (assemble-compiled-procedure-entry a-compiled-procedure-entry)
|
||||
(: assemble-compiled-procedure-entry (CompiledProcedureEntry Blockht -> String))
|
||||
(define (assemble-compiled-procedure-entry a-compiled-procedure-entry blockht)
|
||||
(format "(~a).label"
|
||||
(assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry))))
|
||||
(assemble-oparg (CompiledProcedureEntry-proc a-compiled-procedure-entry)
|
||||
blockht)))
|
||||
|
||||
|
||||
(: assemble-compiled-procedure-closure-reference (CompiledProcedureClosureReference -> String))
|
||||
(define (assemble-compiled-procedure-closure-reference a-ref)
|
||||
(: assemble-compiled-procedure-closure-reference (CompiledProcedureClosureReference Blockht -> String))
|
||||
(define (assemble-compiled-procedure-closure-reference a-ref blockht)
|
||||
(format "(~a).closedVals[(~a).closedVals.length - ~a]"
|
||||
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref))
|
||||
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref))
|
||||
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht)
|
||||
(assemble-oparg (CompiledProcedureClosureReference-proc a-ref) blockht)
|
||||
(add1 (CompiledProcedureClosureReference-n a-ref))))
|
||||
|
||||
|
||||
|
|
@ -379,9 +389,38 @@
|
|||
|
||||
|
||||
|
||||
(: assemble-jump (OpArg -> String))
|
||||
(define (assemble-jump target)
|
||||
(format "return(~a)(M);" (assemble-oparg target)))
|
||||
|
||||
(: assemble-jump (OpArg Blockht -> String))
|
||||
(define (assemble-jump target blockht)
|
||||
|
||||
(define (default)
|
||||
(format "return(~a)(M);" (assemble-oparg target blockht)))
|
||||
|
||||
;; Optimization: if the target of the jump goes to a block whose
|
||||
;; only body is a si-context-expected_1, then jump directly to that code.
|
||||
(cond
|
||||
[(Label? target)
|
||||
(define target-block (hash-ref blockht (Label-name target)))
|
||||
(cond
|
||||
[(block-looks-like-context-expected-values? target-block)
|
||||
=>
|
||||
(lambda (expected)
|
||||
(format "RT.si_context_expected(~a)(M);\n" expected))]
|
||||
[else
|
||||
(default)])]
|
||||
[else
|
||||
(default)]))
|
||||
|
||||
|
||||
|
||||
(: block-looks-like-context-expected-values? (BasicBlock -> (U Natural False)))
|
||||
(define (block-looks-like-context-expected-values? a-block)
|
||||
(match (BasicBlock-stmts a-block)
|
||||
[(list (struct PerformStatement ((struct RaiseContextExpectedValuesError! (expected))))
|
||||
stmts ...)
|
||||
expected]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
|
||||
|
||||
|
|
@ -399,13 +438,13 @@
|
|||
|
||||
|
||||
|
||||
(: assemble-location ((U Reg Label) -> String))
|
||||
(define (assemble-location a-location)
|
||||
(: assemble-location ((U Reg Label) Blockht -> String))
|
||||
(define (assemble-location a-location blockht)
|
||||
(cond
|
||||
[(Reg? a-location)
|
||||
(assemble-reg a-location)]
|
||||
[(Label? a-location)
|
||||
(assemble-label a-location)]))
|
||||
(assemble-label a-location blockht)]))
|
||||
|
||||
|
||||
(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
"../compiler/il-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../compiler/kernel-primitives.rkt"
|
||||
"assemble-structs.rkt"
|
||||
racket/string
|
||||
racket/list
|
||||
typed/rackunit)
|
||||
|
|
@ -12,10 +13,12 @@
|
|||
|
||||
|
||||
|
||||
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
|
||||
(define (open-code-kernel-primitive-procedure op)
|
||||
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure Blockht -> String))
|
||||
(define (open-code-kernel-primitive-procedure op blockht)
|
||||
(let*: ([operator : KernelPrimitiveName/Inline (CallKernelPrimitiveProcedure-operator op)]
|
||||
[operands : (Listof String) (map assemble-oparg (CallKernelPrimitiveProcedure-operands op))]
|
||||
[operands : (Listof String) (map (lambda: ([op : OpArg])
|
||||
(assemble-oparg op blockht))
|
||||
(CallKernelPrimitiveProcedure-operands op))]
|
||||
[checked-operands : (Listof String)
|
||||
(map (lambda: ([dom : OperandDomain]
|
||||
[pos : Natural]
|
||||
|
|
|
|||
|
|
@ -3,14 +3,15 @@
|
|||
"../compiler/il-structs.rkt"
|
||||
"../compiler/lexical-structs.rkt"
|
||||
"../parameters.rkt"
|
||||
"assemble-structs.rkt"
|
||||
racket/string)
|
||||
|
||||
(provide assemble-op-statement)
|
||||
|
||||
|
||||
|
||||
(: assemble-op-statement (PrimitiveCommand -> String))
|
||||
(define (assemble-op-statement op)
|
||||
(: assemble-op-statement (PrimitiveCommand Blockht -> String))
|
||||
(define (assemble-op-statement op blockht)
|
||||
(cond
|
||||
|
||||
[(CheckToplevelBound!? op)
|
||||
|
|
@ -83,7 +84,7 @@
|
|||
[(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag)])))]
|
||||
(assemble-oparg tag blockht)])))]
|
||||
|
||||
[(FixClosureShellMap!? op)
|
||||
(format "M.e[M.e.length-~a].closedVals=[~a];"
|
||||
|
|
@ -99,16 +100,18 @@
|
|||
|
||||
[(SetFrameCallee!? op)
|
||||
(format "M.c[M.c.length-1].p=~a;"
|
||||
(assemble-oparg (SetFrameCallee!-proc op)))]
|
||||
(assemble-oparg (SetFrameCallee!-proc op)
|
||||
blockht))]
|
||||
|
||||
[(SpliceListIntoStack!? op)
|
||||
(format "M.spliceListIntoStack(~a);"
|
||||
(assemble-oparg (SpliceListIntoStack!-depth op)))]
|
||||
(assemble-oparg (SpliceListIntoStack!-depth op)
|
||||
blockht))]
|
||||
|
||||
[(UnspliceRestFromStack!? op)
|
||||
(format "M.unspliceRestFromStack(~a,~a);"
|
||||
(assemble-oparg (UnspliceRestFromStack!-depth op))
|
||||
(assemble-oparg (UnspliceRestFromStack!-length op)))]
|
||||
(assemble-oparg (UnspliceRestFromStack!-depth op) blockht)
|
||||
(assemble-oparg (UnspliceRestFromStack!-length op) blockht))]
|
||||
|
||||
[(InstallContinuationMarkEntry!? op)
|
||||
(string-append "M.installContinuationMarkEntry("
|
||||
|
|
@ -122,13 +125,13 @@
|
|||
|
||||
[(RaiseArityMismatchError!? op)
|
||||
(format "RT.raiseArityMismatchError(M,~a,~a);"
|
||||
(assemble-oparg (RaiseArityMismatchError!-proc op))
|
||||
(assemble-oparg (RaiseArityMismatchError!-received op)))]
|
||||
(assemble-oparg (RaiseArityMismatchError!-proc op) blockht)
|
||||
(assemble-oparg (RaiseArityMismatchError!-received op) blockht))]
|
||||
|
||||
|
||||
[(RaiseOperatorApplicationError!? op)
|
||||
(format "RT.raiseOperatorApplicationError(M,~a);"
|
||||
(assemble-oparg (RaiseOperatorApplicationError!-operator op)))]
|
||||
(assemble-oparg (RaiseOperatorApplicationError!-operator op) blockht))]
|
||||
|
||||
|
||||
[(RaiseUnimplementedPrimitiveError!? op)
|
||||
|
|
@ -140,7 +143,8 @@
|
|||
(format "M.modules[~s]=new RT.ModuleRecord(~s,~a);"
|
||||
(symbol->string (ModuleLocator-name (InstallModuleEntry!-path op)))
|
||||
(symbol->string (InstallModuleEntry!-name op))
|
||||
(assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]
|
||||
(assemble-label (make-Label (InstallModuleEntry!-entry-point op))
|
||||
blockht))]
|
||||
|
||||
[(MarkModuleInvoked!? op)
|
||||
(format "M.modules[~s].isInvoked=true;"
|
||||
|
|
|
|||
|
|
@ -13,3 +13,8 @@
|
|||
(define-struct: BasicBlock ([name : Symbol]
|
||||
[stmts : (Listof UnlabeledStatement)])
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
||||
;; Represents a hashtable from symbols to basic blocks
|
||||
(define-type Blockht (HashTable Symbol BasicBlock))
|
||||
|
|
|
|||
|
|
@ -29,8 +29,6 @@
|
|||
(define current-emit-debug-trace? (make-parameter #f))
|
||||
|
||||
|
||||
;; Represents a hashtable from symbols to basic blocks
|
||||
(define-type Blockht (HashTable Symbol BasicBlock))
|
||||
|
||||
|
||||
|
||||
|
|
@ -48,12 +46,19 @@
|
|||
(define function-entry-and-exit-names
|
||||
(list->set (get-function-entry-and-exit-names stmts)))
|
||||
|
||||
(: blockht : Blockht)
|
||||
(define blockht (make-hash))
|
||||
|
||||
(for ([b basic-blocks])
|
||||
(hash-set! blockht (BasicBlock-name b) b))
|
||||
|
||||
(write-blocks basic-blocks
|
||||
blockht
|
||||
(list->set entry-points)
|
||||
function-entry-and-exit-names
|
||||
op)
|
||||
|
||||
(write-linked-label-attributes stmts op)
|
||||
(write-linked-label-attributes stmts blockht op)
|
||||
|
||||
(display "M.params.currentErrorHandler = fail;\n" op)
|
||||
(display "M.params.currentSuccessHandler = success;\n" op)
|
||||
|
|
@ -66,18 +71,14 @@ for (param in params) {
|
|||
EOF
|
||||
op)
|
||||
(fprintf op "M.trampoline(~a, true); })"
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks))))))
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))
|
||||
blockht)))
|
||||
|
||||
|
||||
|
||||
(: write-blocks ((Listof BasicBlock) (Setof Symbol) (Setof Symbol) Output-Port -> Void))
|
||||
(: write-blocks ((Listof BasicBlock) Blockht (Setof Symbol) (Setof Symbol) Output-Port -> Void))
|
||||
;; Write out all the basic blocks associated to an entry point.
|
||||
(define (write-blocks blocks entry-points function-entry-and-exit-names op)
|
||||
(: blockht : Blockht)
|
||||
(define blockht (make-hash))
|
||||
|
||||
(for ([b blocks])
|
||||
(hash-set! blockht (BasicBlock-name b) b))
|
||||
(define (write-blocks blocks blockht entry-points function-entry-and-exit-names op)
|
||||
|
||||
;; Since there may be cycles between the blocks, we cut the cycles by
|
||||
;; making them entry points as well.
|
||||
|
|
@ -124,15 +125,15 @@ EOF
|
|||
|
||||
|
||||
|
||||
(: write-linked-label-attributes ((Listof Statement) Output-Port -> 'ok))
|
||||
(define (write-linked-label-attributes stmts op)
|
||||
(: write-linked-label-attributes ((Listof Statement) Blockht Output-Port -> 'ok))
|
||||
(define (write-linked-label-attributes stmts blockht op)
|
||||
(cond
|
||||
[(empty? stmts)
|
||||
'ok]
|
||||
[else
|
||||
(let: ([stmt : Statement (first stmts)])
|
||||
|
||||
(define (next) (write-linked-label-attributes (rest stmts) op))
|
||||
(define (next) (write-linked-label-attributes (rest stmts) blockht op))
|
||||
|
||||
(cond
|
||||
[(symbol? stmt)
|
||||
|
|
@ -140,8 +141,8 @@ EOF
|
|||
[(LinkedLabel? stmt)
|
||||
;; Setting up multiple-value-return
|
||||
(fprintf op "~a.mvr=~a;\n"
|
||||
(assemble-label (make-Label (LinkedLabel-label stmt)))
|
||||
(assemble-label (make-Label (LinkedLabel-linked-to stmt))))
|
||||
(assemble-label (make-Label (LinkedLabel-label stmt)) blockht)
|
||||
(assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))
|
||||
(next)]
|
||||
[(DebugPrint? stmt)
|
||||
(next)]
|
||||
|
|
@ -179,15 +180,17 @@ EOF
|
|||
|
||||
(: assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
|
||||
(define (assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
|
||||
(match (BasicBlock-stmts a-basic-block)
|
||||
[(list (struct PerformStatement ((struct RaiseContextExpectedValuesError! (expected))))
|
||||
stmts ...)
|
||||
(fprintf op "~a=RT.si_context_expected(~a);\n"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)))
|
||||
expected)
|
||||
'ok]
|
||||
[else
|
||||
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
|
||||
(cond
|
||||
[(block-looks-like-context-expected-values? a-basic-block)
|
||||
=>
|
||||
(lambda (expected)
|
||||
(fprintf op "~a=RT.si_context_expected(~a);\n"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block))
|
||||
blockht)
|
||||
expected)
|
||||
'ok)]
|
||||
[else
|
||||
(default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
|
||||
|
||||
|
||||
|
||||
|
|
@ -196,11 +199,11 @@ EOF
|
|||
(cond
|
||||
[(set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
|
||||
(fprintf op "var ~a=function(M){if(--M.cbt<0){throw ~a;}\n"
|
||||
(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)) blockht)
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht))]
|
||||
[else
|
||||
(fprintf op "var ~a=function(M){--M.cbt<0;\n"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block))))])
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht))])
|
||||
(assemble-block-statements (BasicBlock-name a-basic-block)
|
||||
(BasicBlock-stmts a-basic-block)
|
||||
blockht
|
||||
|
|
@ -221,7 +224,7 @@ EOF
|
|||
(not (GotoStatement? stmt)))
|
||||
(log-debug (format "Last statement of the block ~a is not a goto" name)))
|
||||
|
||||
(display (assemble-statement stmt) op)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
(newline op)
|
||||
(assemble-block-statements name
|
||||
(rest stmts)
|
||||
|
|
@ -253,30 +256,33 @@ EOF
|
|||
(define test-code (cond
|
||||
[(TestFalse? test)
|
||||
(format "if(~a===false)"
|
||||
(assemble-oparg (TestFalse-operand test)))]
|
||||
(assemble-oparg (TestFalse-operand test)
|
||||
blockht))]
|
||||
[(TestTrue? test)
|
||||
(format "if(~a!==false)"
|
||||
(assemble-oparg (TestTrue-operand test)))]
|
||||
(assemble-oparg (TestTrue-operand test)
|
||||
blockht))]
|
||||
[(TestOne? test)
|
||||
(format "if(~a===1)"
|
||||
(assemble-oparg (TestOne-operand test)))]
|
||||
(assemble-oparg (TestOne-operand test)
|
||||
blockht))]
|
||||
[(TestZero? test)
|
||||
(format "if(~a===0)"
|
||||
(assemble-oparg (TestZero-operand test)))]
|
||||
|
||||
;; [(TestPrimitiveProcedure? test)
|
||||
;; (format "if(typeof(~a)==='function')"
|
||||
;; (assemble-oparg (TestPrimitiveProcedure-operand test)))]
|
||||
(assemble-oparg (TestZero-operand test)
|
||||
blockht))]
|
||||
|
||||
[(TestClosureArityMismatch? test)
|
||||
(format "if(!RT.isArityMatching((~a).racketArity,~a))"
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test))
|
||||
(assemble-oparg (TestClosureArityMismatch-n test)))]))
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test)
|
||||
blockht)
|
||||
(assemble-oparg (TestClosureArityMismatch-n test)
|
||||
blockht))]))
|
||||
(display test-code op)
|
||||
(display "{" op)
|
||||
(cond
|
||||
[(set-contains? entry-points (TestAndJumpStatement-label stmt))
|
||||
(display (assemble-jump (make-Label (TestAndJumpStatement-label stmt))) op)]
|
||||
(display (assemble-jump (make-Label (TestAndJumpStatement-label stmt))
|
||||
blockht) op)]
|
||||
[else
|
||||
(assemble-block-statements (BasicBlock-name
|
||||
(hash-ref blockht (TestAndJumpStatement-label stmt)))
|
||||
|
|
@ -306,7 +312,7 @@ EOF
|
|||
(GotoStatement? (first target-statements)))
|
||||
(loop (first target-statements))]
|
||||
[(set-contains? entry-points (Label-name target))
|
||||
(display (assemble-statement stmt) op)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[else
|
||||
(log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
|
||||
|
|
@ -316,13 +322,13 @@ EOF
|
|||
entry-points
|
||||
op)])]
|
||||
[(Reg? target)
|
||||
(display (assemble-statement stmt) op)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[(ModuleEntry? target)
|
||||
(display (assemble-statement stmt) op)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]
|
||||
[(CompiledProcedureEntry? target)
|
||||
(display (assemble-statement stmt) op)
|
||||
(display (assemble-statement stmt blockht) op)
|
||||
'ok]))]
|
||||
|
||||
|
||||
|
|
@ -429,57 +435,67 @@ EOF
|
|||
|
||||
|
||||
|
||||
(: assemble-statement (UnlabeledStatement -> String))
|
||||
(: assemble-statement (UnlabeledStatement Blockht -> String))
|
||||
;; Generates the code to assemble a statement.
|
||||
(define (assemble-statement stmt)
|
||||
(define (assemble-statement stmt blockht)
|
||||
(define assembled
|
||||
(cond
|
||||
[(DebugPrint? stmt)
|
||||
(format "M.params.currentOutputPort.writeDomNode(M, $('<span/>').text(~a));"
|
||||
(assemble-oparg (DebugPrint-value stmt)))]
|
||||
(assemble-oparg (DebugPrint-value stmt)
|
||||
blockht))]
|
||||
[(AssignImmediateStatement? stmt)
|
||||
(let: ([t : (String -> String) (assemble-target (AssignImmediateStatement-target stmt))]
|
||||
[v : OpArg (AssignImmediateStatement-value stmt)])
|
||||
(t (assemble-oparg v)))]
|
||||
(t (assemble-oparg v blockht)))]
|
||||
|
||||
[(AssignPrimOpStatement? stmt)
|
||||
((assemble-target (AssignPrimOpStatement-target stmt))
|
||||
(assemble-op-expression (AssignPrimOpStatement-op stmt)))]
|
||||
(assemble-op-expression (AssignPrimOpStatement-op stmt)
|
||||
blockht))]
|
||||
|
||||
[(PerformStatement? stmt)
|
||||
(assemble-op-statement (PerformStatement-op stmt))]
|
||||
(assemble-op-statement (PerformStatement-op stmt) blockht)]
|
||||
|
||||
[(TestAndJumpStatement? stmt)
|
||||
(let*: ([test : PrimitiveTest (TestAndJumpStatement-op stmt)]
|
||||
[jump : String (assemble-jump
|
||||
(make-Label (TestAndJumpStatement-label stmt)))])
|
||||
(make-Label (TestAndJumpStatement-label stmt))
|
||||
blockht)])
|
||||
;; 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))
|
||||
(assemble-oparg (TestFalse-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestTrue? test)
|
||||
(format "if(~a!==false){~a}"
|
||||
(assemble-oparg (TestTrue-operand test))
|
||||
(assemble-oparg (TestTrue-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestOne? test)
|
||||
(format "if(~a===1){~a}"
|
||||
(assemble-oparg (TestOne-operand test))
|
||||
(assemble-oparg (TestOne-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestZero? test)
|
||||
(format "if(~a===0){~a}"
|
||||
(assemble-oparg (TestZero-operand test))
|
||||
(assemble-oparg (TestZero-operand test)
|
||||
blockht)
|
||||
jump)]
|
||||
[(TestClosureArityMismatch? test)
|
||||
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test))
|
||||
(assemble-oparg (TestClosureArityMismatch-n test))
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test)
|
||||
blockht)
|
||||
(assemble-oparg (TestClosureArityMismatch-n test)
|
||||
blockht)
|
||||
jump)])
|
||||
String))]
|
||||
|
||||
[(GotoStatement? stmt)
|
||||
(assemble-jump (GotoStatement-target stmt))]
|
||||
(assemble-jump (GotoStatement-target stmt)
|
||||
blockht)]
|
||||
|
||||
[(PushControlFrame/Generic? stmt)
|
||||
"M.c.push(new RT.Frame());"]
|
||||
|
|
@ -489,9 +505,11 @@ EOF
|
|||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label))]
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label)))])))]
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)])))]
|
||||
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
;; fixme: use a different frame structure
|
||||
|
|
@ -499,9 +517,11 @@ EOF
|
|||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label))]
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label)))]))
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)]))
|
||||
|
||||
(let: ([tag : (U DefaultContinuationPromptTag OpArg)
|
||||
(PushControlFrame/Prompt-tag stmt)])
|
||||
|
|
@ -509,7 +529,7 @@ EOF
|
|||
[(DefaultContinuationPromptTag? tag)
|
||||
(assemble-default-continuation-prompt-tag)]
|
||||
[(OpArg? tag)
|
||||
(assemble-oparg tag)])))]
|
||||
(assemble-oparg tag blockht)])))]
|
||||
|
||||
[(PopControlFrame? stmt)
|
||||
"M.c.pop();"]
|
||||
|
|
@ -530,20 +550,22 @@ EOF
|
|||
(cond
|
||||
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
|
||||
(format "M.e.length-=~a;"
|
||||
(assemble-oparg (PopEnvironment-n stmt)))]
|
||||
(assemble-oparg (PopEnvironment-n stmt) blockht))]
|
||||
[else
|
||||
(format "M.e.splice(M.e.length-(~a+~a),~a);"
|
||||
(assemble-oparg (PopEnvironment-skip stmt))
|
||||
(assemble-oparg (PopEnvironment-n stmt))
|
||||
(assemble-oparg (PopEnvironment-n stmt)))]))]
|
||||
(assemble-oparg (PopEnvironment-skip stmt) blockht)
|
||||
(assemble-oparg (PopEnvironment-n stmt) blockht)
|
||||
(assemble-oparg (PopEnvironment-n stmt) blockht))]))]
|
||||
|
||||
[(PushImmediateOntoEnvironment? stmt)
|
||||
(format "M.e.push(~a);"
|
||||
(let: ([val-string : String
|
||||
(cond [(PushImmediateOntoEnvironment-box? stmt)
|
||||
(format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)))]
|
||||
(format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
|
||||
blockht))]
|
||||
[else
|
||||
(assemble-oparg (PushImmediateOntoEnvironment-value stmt))])])
|
||||
(assemble-oparg (PushImmediateOntoEnvironment-value stmt)
|
||||
blockht)])])
|
||||
val-string))]
|
||||
[(Comment? stmt)
|
||||
;; TODO: maybe comments should be emitted as JavaScript comments.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user