diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt
index 623e723..10c6973 100644
--- a/compiler/compiler.rkt
+++ b/compiler/compiler.rkt
@@ -440,7 +440,7 @@
(append-instruction-sequences
(make-AssignImmediate 'argcount (make-Const 1))
(make-Perform (make-RaiseContextExpectedValuesError!
- context))))]))]))
+ context))))]))]))
@@ -453,7 +453,7 @@
cenv
(append-instruction-sequences
(make-AssignImmediate target (make-Const
- (ensure-const-value (Constant-v exp))))
+ (ensure-const-value (Constant-v exp))))
singular-context-check))))
@@ -476,8 +476,8 @@
cenv
(append-instruction-sequences
(make-AssignImmediate target
- (make-EnvLexicalReference (LocalRef-depth exp)
- (LocalRef-unbox? exp)))
+ (make-EnvLexicalReference (LocalRef-depth exp)
+ (LocalRef-unbox? exp)))
singular-context-check))))
@@ -490,35 +490,35 @@
(end-with-linkage linkage
cenv
(append-instruction-sequences
-
+
;; If it's a module variable, we need to look there.
(cond
- [(ModuleVariable? prefix-element)
- (cond [(kernel-module-name? (ModuleVariable-module-name prefix-element))
- (make-AssignPrimOp target
- (make-PrimitivesReference
- (kernel-module-variable->primitive-name
- prefix-element)
- ))]
- [else
- (make-AssignImmediate
- target
- (make-EnvPrefixReference (ToplevelRef-depth exp)
- (ToplevelRef-pos exp)
- #t))])]
- [else
- (append-instruction-sequences
- (if (ToplevelRef-check-defined? exp)
- (make-Perform (make-CheckToplevelBound!
- (ToplevelRef-depth exp)
- (ToplevelRef-pos exp)))
- empty-instruction-sequence)
- (make-AssignImmediate
- target
- (make-EnvPrefixReference (ToplevelRef-depth exp)
- (ToplevelRef-pos exp)
- #f)))])
- singular-context-check))))
+ [(ModuleVariable? prefix-element)
+ (cond [(kernel-module-name? (ModuleVariable-module-name prefix-element))
+ (make-AssignPrimOp target
+ (make-PrimitivesReference
+ (kernel-module-variable->primitive-name
+ prefix-element)
+ ))]
+ [else
+ (make-AssignImmediate
+ target
+ (make-EnvPrefixReference (ToplevelRef-depth exp)
+ (ToplevelRef-pos exp)
+ #t))])]
+ [else
+ (append-instruction-sequences
+ (if (ToplevelRef-check-defined? exp)
+ (make-Perform (make-CheckToplevelBound!
+ (ToplevelRef-depth exp)
+ (ToplevelRef-pos exp)))
+ empty-instruction-sequence)
+ (make-AssignImmediate
+ target
+ (make-EnvPrefixReference (ToplevelRef-depth exp)
+ (ToplevelRef-pos exp)
+ #f)))])
+ singular-context-check))))
@@ -532,20 +532,20 @@
(define prefix-element (list-ref (Prefix-names prefix) (ToplevelSet-pos exp)))
(let ([get-value-code
(cond
- [(ModuleVariable? prefix-element)
- (compile (ToplevelSet-value exp)
- cenv
- (make-EnvPrefixReference (ToplevelSet-depth exp)
- (ToplevelSet-pos exp)
- #t)
- next-linkage/expects-single)]
- [else
- (compile (ToplevelSet-value exp)
- cenv
- (make-EnvPrefixReference (ToplevelSet-depth exp)
- (ToplevelSet-pos exp)
- #f)
- next-linkage/expects-single)])]
+ [(ModuleVariable? prefix-element)
+ (compile (ToplevelSet-value exp)
+ cenv
+ (make-EnvPrefixReference (ToplevelSet-depth exp)
+ (ToplevelSet-pos exp)
+ #t)
+ next-linkage/expects-single)]
+ [else
+ (compile (ToplevelSet-value exp)
+ cenv
+ (make-EnvPrefixReference (ToplevelSet-depth exp)
+ (ToplevelSet-pos exp)
+ #f)
+ next-linkage/expects-single)])]
[singular-context-check (emit-singular-context linkage)])
(end-with-linkage
linkage
@@ -576,7 +576,7 @@
(append-instruction-sequences
p-code
(make-TestAndJump (make-TestFalse (make-Reg 'val))
- f-branch:)
+ f-branch:)
c-code
f-branch: a-code
(if (NextLinkage? linkage)
@@ -648,7 +648,6 @@
(let ([evaluate-and-save-first-expression
(let ([after-first-seq (make-label 'afterFirstSeqEvaluated)])
(append-instruction-sequences
- (make-Comment "begin0")
;; Evaluate the first expression in a multiple-value context, and get the values on the stack.
(compile (first seq) cenv 'val next-linkage/keep-multiple-on-stack)
@@ -659,10 +658,10 @@
;; Next, we save those values temporarily in a throwaway control frame.
(make-PushControlFrame/Generic)
(make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Count)
- (make-Reg 'argcount))
+ (make-Reg 'argcount))
(make-Perform (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount)))
(make-AssignImmediate (make-ControlFrameTemporary 'pendingBegin0Values)
- (make-EnvLexicalReference 0 #f))
+ (make-EnvLexicalReference 0 #f))
(make-PopEnvironment (make-Const 1) (make-Const 0))))]
[reinstate-values-on-stack
@@ -764,7 +763,6 @@
(append-instruction-sequences
;; Make some temporary space for the lambdas
- (make-Comment "scratch space for case-lambda")
(make-PushEnvironment n #f)
;; Compile each of the lambdas
@@ -870,36 +868,44 @@
singular-context-check))))
+
+;; We keep track of which lambda is currently being compiled for potential optimizations
+;; e.g. self tail calls.
+(: current-lambda-body-being-compiled (Parameterof (U #f Lam)))
+(define current-lambda-body-being-compiled (make-parameter #f))
+
+
(: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence))
;; Compiles the body of the lambda in the appropriate environment.
;; Closures will target their value to the 'val register, and use return linkage.
(define (compile-lambda-body exp cenv)
- (let: ([maybe-unsplice-rest-argument : InstructionSequence
- (if (Lam-rest? exp)
- (make-Perform
- (make-UnspliceRestFromStack!
- (make-Const (Lam-num-parameters exp))
- (new-SubtractArg (make-Reg 'argcount)
- (make-Const (Lam-num-parameters exp)))))
- empty-instruction-sequence)]
- [maybe-install-closure-values : InstructionSequence
- (if (not (empty? (Lam-closure-map exp)))
- (append-instruction-sequences
- (make-Comment (format "installing closure for ~s" (Lam-name exp)))
- (make-Perform (make-InstallClosureValues!
- (length (Lam-closure-map exp)))))
- empty-instruction-sequence)]
- [lam-body-code : InstructionSequence
- (compile (Lam-body exp)
- (extract-lambda-cenv exp cenv)
- 'val
- return-linkage)])
-
- (append-instruction-sequences
- (Lam-entry-label exp)
- maybe-unsplice-rest-argument
- maybe-install-closure-values
- lam-body-code)))
+ (parameterize ([current-lambda-body-being-compiled exp])
+ (let: ([maybe-unsplice-rest-argument : InstructionSequence
+ (if (Lam-rest? exp)
+ (make-Perform
+ (make-UnspliceRestFromStack!
+ (make-Const (Lam-num-parameters exp))
+ (new-SubtractArg (make-Reg 'argcount)
+ (make-Const (Lam-num-parameters exp)))))
+ empty-instruction-sequence)]
+ [maybe-install-closure-values : InstructionSequence
+ (if (not (empty? (Lam-closure-map exp)))
+ (append-instruction-sequences
+ (make-Perform (make-InstallClosureValues!
+ (length (Lam-closure-map exp)))))
+ empty-instruction-sequence)]
+ [lam-body-code : InstructionSequence
+ (compile (Lam-body exp)
+ (extract-lambda-cenv exp cenv)
+ 'val
+ return-linkage)])
+
+ (append-instruction-sequences
+ (Lam-entry-label exp)
+ (Comment (format "lambda body for ~a" (Lam-name exp)))
+ maybe-unsplice-rest-argument
+ maybe-install-closure-values
+ lam-body-code))))
(: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence))
@@ -914,21 +920,21 @@
(let ([not-match (make-label 'notMatch)])
(append-instruction-sequences
(make-TestAndJump (make-TestClosureArityMismatch
- (make-CompiledProcedureClosureReference
- (make-Reg 'proc)
- i)
- (make-Reg 'argcount))
- not-match)
+ (make-CompiledProcedureClosureReference
+ (make-Reg 'proc)
+ i)
+ (make-Reg 'argcount))
+ not-match)
;; Set the procedure register to the lam
(make-AssignImmediate
'proc
(make-CompiledProcedureClosureReference (make-Reg 'proc) i))
(make-Goto (make-Label
- (cond [(Lam? lam)
- (Lam-entry-label lam)]
- [(EmptyClosureReference? lam)
- (EmptyClosureReference-entry-label lam)])))
+ (cond [(Lam? lam)
+ (Lam-entry-label lam)]
+ [(EmptyClosureReference? lam)
+ (EmptyClosureReference-entry-label lam)])))
not-match)))
(CaseLam-clauses exp)
@@ -980,7 +986,7 @@
(define (default)
(compile-general-application exp cenv target linkage))
-
+
(let: ([op-knowledge : CompileTimeEnvironmentEntry
(extract-static-knowledge (App-operator exp)
extended-cenv)])
@@ -1027,8 +1033,8 @@
-
-
+
+
(: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-general-application exp cenv target linkage)
@@ -1058,12 +1064,11 @@
'val))))])
(append-instruction-sequences
- (make-Comment "scratch space for general application")
(make-PushEnvironment (length (App-operands exp)) #f)
proc-code
(juggle-operands operand-codes)
(make-AssignImmediate 'argcount
- (make-Const (length (App-operands exp))))
+ (make-Const (length (App-operands exp))))
(compile-general-procedure-call cenv
(make-Const (length (App-operands exp)))
target
@@ -1143,11 +1148,11 @@
(make-EnvLexicalReference i #f)))))
(make-AssignImmediate 'proc (make-PrimitiveKernelValue kernel-op))
(make-AssignImmediate 'argcount
- (make-Const (length (App-operands exp))))
+ (make-Const (length (App-operands exp))))
(make-Perform (make-RaiseArityMismatchError!
- (make-Reg 'proc)
- expected-arity
- (make-Const n))))))
+ (make-Reg 'proc)
+ expected-arity
+ (make-Const n))))))
(cond
[(IncorrectArity? expected-operand-types)
@@ -1190,11 +1195,11 @@
linkage cenv
(append-instruction-sequences
(make-AssignPrimOp target
- (make-CallKernelPrimitiveProcedure
- kernel-op
- operand-poss
- expected-operand-types
- typechecks?))
+ (make-CallKernelPrimitiveProcedure
+ kernel-op
+ operand-poss
+ expected-operand-types
+ typechecks?))
singular-context-check)))]
[else
@@ -1224,9 +1229,9 @@
rest-operands))]
[(constant-operand-knowledge)
(map (lambda: ([arg : Expression])
- (extract-static-knowledge arg extended-cenv))
+ (extract-static-knowledge arg extended-cenv))
constant-operands)]
-
+
[(operand-knowledge)
(append constant-operand-knowledge
(map (lambda: ([arg : Expression])
@@ -1304,11 +1309,11 @@
(LocalRef-unbox? e))]
[(ToplevelRef? e)
(cond
- [(ModuleVariable? k)
- (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #t)]
-
- [else
- (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #f)])]
+ [(ModuleVariable? k)
+ (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #t)]
+
+ [else
+ (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e) #f)])]
[else
(error 'all-operands-are-constant "Impossible")]))
rands
@@ -1428,7 +1433,6 @@
'proc
next-linkage/expects-single)])
(append-instruction-sequences
- (make-Comment "scratch space for statically known lambda application")
(make-PushEnvironment (length (App-operands exp)) #f)
(apply append-instruction-sequences operand-codes)
proc-code
@@ -1458,9 +1462,9 @@
(append-instruction-sequences
(car ops)
(make-AssignImmediate 'proc
- (make-EnvLexicalReference n #f))
+ (make-EnvLexicalReference n #f))
(make-AssignImmediate (make-EnvLexicalReference n #f)
- (make-Reg 'val))))]
+ (make-Reg 'val))))]
[else
;; Otherwise, add instructions to juggle the operator and operands in the stack.
(append-instruction-sequences (car ops)
@@ -1526,7 +1530,7 @@
empty-instruction-sequence
(make-AssignImmediate target (make-Reg 'val)))
(emit-singular-context linkage))))
-
+
@@ -1544,7 +1548,7 @@
(linkage-context linkage)))])
(append-instruction-sequences
(make-AssignImmediate 'argcount
- (make-Const n))
+ (make-Const n))
(compile-compiled-procedure-application cenv
(make-Const n)
(make-Label
@@ -1685,8 +1689,8 @@
on-return/multiple
;; if the wrong number of arguments come in, die
(make-TestAndJump (make-TestZero (new-SubtractArg (make-Reg 'argcount)
- (make-Const context)))
- after-value-check)
+ (make-Const context)))
+ after-value-check)
on-return
(make-Perform
(make-RaiseContextExpectedValuesError! context))
@@ -1776,7 +1780,7 @@
(make-LabelLinkage after-body-code (linkage-context linkage))])]
[(LabelLinkage? linkage)
(make-LabelLinkage after-body-code (LabelLinkage-context linkage))])]
-
+
[body-target : Target (adjust-target-depth target 1)]
[body-code : InstructionSequence
(compile (Let1-body exp) extended-cenv body-target let-linkage)])
@@ -1784,12 +1788,11 @@
linkage
extended-cenv
(append-instruction-sequences
- (make-Comment "scratch space for let1")
(make-PushEnvironment 1 #f)
rhs-code
body-code
after-body-code
-
+
;; We want to clear out the scratch space introduced by the
;; let1. However, there may be multiple values coming
@@ -1805,7 +1808,7 @@
[(eq? context 'keep-multiple)
;; dynamic number of arguments that need
;; to be preserved
-
+
(make-PopEnvironment (make-Const 1)
(new-SubtractArg
(make-Reg 'argcount)
@@ -1859,7 +1862,6 @@
linkage
extended-cenv
(append-instruction-sequences
- (make-Comment "scratch space for let-void")
(make-PushEnvironment n (LetVoid-boxes? exp))
body-code
after-body-code
@@ -1952,9 +1954,8 @@
(map (lambda: ([lam : Lam]
[i : Natural])
(append-instruction-sequences
- (make-Comment (format "Installing shell for ~s\n" (Lam-name lam)))
(make-Perform (make-FixClosureShellMap! i
- (Lam-closure-map lam)))))
+ (Lam-closure-map lam)))))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) i))))
@@ -1968,7 +1969,6 @@
(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-install-value exp cenv target linkage)
(append-instruction-sequences
- (make-Comment "install-value")
(let ([count (InstallValue-count exp)])
(cond [(= count 0)
(end-with-linkage
@@ -1980,8 +1980,6 @@
(make-NextLinkage 0)))]
[(= count 1)
(append-instruction-sequences
- (make-Comment (format "installing single value into ~s"
- (InstallValue-depth exp)))
(end-with-linkage
linkage
cenv
@@ -1994,7 +1992,6 @@
linkage
cenv
(append-instruction-sequences
- (make-Comment "install-value: evaluating values")
(compile (InstallValue-body exp)
cenv
'val
@@ -2003,7 +2000,6 @@
(map (lambda: ([to : EnvLexicalReference]
[from : OpArg])
(append-instruction-sequences
- (make-Comment "install-value: installing value")
(make-AssignImmediate to from)))
(build-list count (lambda: ([i : Natural])
(make-EnvLexicalReference (+ i
@@ -2021,7 +2017,7 @@
(define (compile-box-environment-value exp cenv target linkage)
(append-instruction-sequences
(make-AssignPrimOp (make-EnvLexicalReference (BoxEnv-depth exp) #f)
- (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp)))
+ (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp)))
(compile (BoxEnv-body exp) cenv target linkage)))
@@ -2051,15 +2047,15 @@
context on-return/multiple: on-return:)]
[maybe-migrate-val-to-target
(cond
- [(eq? target 'val)
- empty-instruction-sequence]
- [else
- (make-AssignImmediate target (make-Reg 'val))])])
+ [(eq? target 'val)
+ empty-instruction-sequence]
+ [else
+ (make-AssignImmediate target (make-Reg 'val))])])
(append-instruction-sequences
(make-PushControlFrame/Call on-return:)
(compile (WithContMark-key exp) cenv 'val next-linkage/expects-single)
(make-AssignImmediate (make-ControlFrameTemporary 'pendingContinuationMarkKey)
- (make-Reg 'val))
+ (make-Reg 'val))
(compile (WithContMark-value exp) cenv 'val next-linkage/expects-single)
(make-Perform (make-InstallContinuationMarkEntry!))
(compile (WithContMark-body exp) cenv 'val return-linkage/nontail)
diff --git a/compiler/optimize-il.rkt b/compiler/optimize-il.rkt
index 237e4c0..f4f7913 100644
--- a/compiler/optimize-il.rkt
+++ b/compiler/optimize-il.rkt
@@ -193,8 +193,8 @@
]
[(Comment? a-stmt)
- (loop (rest stmts))
- ;(cons a-stmt (loop (rest stmts)))
+ ;(loop (rest stmts))
+ (cons a-stmt (loop (rest stmts)))
]
[(AssignImmediate? a-stmt)
@@ -386,7 +386,7 @@
[(PopControlFrame? stmt)
#f]
[(Comment? stmt)
- #t]))
+ #f]))
diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt
index 863648b..13e6283 100644
--- a/js-assembler/assemble.rkt
+++ b/js-assembler/assemble.rkt
@@ -13,8 +13,7 @@
"../sets.rkt"
"../helpers.rkt"
racket/string
- racket/list
- racket/match)
+ racket/list)
(require/typed "../logger.rkt"
[log-debug (String -> Void)])
@@ -26,7 +25,7 @@
;; Parameter that controls the generation of a trace.
-(define current-emit-debug-trace? (make-parameter #f))
+(define emit-debug-trace? #f)
@@ -42,16 +41,16 @@
(display "var RT = plt.runtime;\n" op)
(define-values (basic-blocks entry-points) (fracture stmts))
-
+
(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)
@@ -69,7 +68,7 @@ for (param in params) {
}
}
EOF
- op)
+ op)
(fprintf op "M.trampoline(~a, true); })"
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))
blockht)))
@@ -83,7 +82,7 @@ EOF
;; Since there may be cycles between the blocks, we cut the cycles by
;; making them entry points as well.
(insert-cycles-as-entry-points! entry-points blockht)
-
+
(set-for-each (lambda: ([s : Symbol])
(log-debug (format "Emitting code for basic block ~s" s))
(assemble-basic-block (hash-ref blockht s)
@@ -111,15 +110,15 @@ EOF
(cond
[(set-contains? visited next-to-visit)
#;(unless (set-contains? entry-points next-to-visit)
- (log-debug (format "Promoting ~a to an entry point" next-to-visit))
- (set-insert! entry-points next-to-visit))
+ (log-debug (format "Promoting ~a to an entry point" next-to-visit))
+ (set-insert! entry-points next-to-visit))
(loop (rest queue))]
[else
(set-insert! visited next-to-visit)
(set-insert! entry-points next-to-visit)
(loop (list-union (basic-block-out-edges (hash-ref blockht next-to-visit))
(rest queue)))])]))
-
+
(loop (set->list entry-points)))
@@ -146,19 +145,19 @@ EOF
;; that if .mvr is missing, that the block only expects one.
(define linked-to-block (hash-ref blockht (LinkedLabel-linked-to stmt)))
(cond
- [(block-looks-like-context-expected-values? linked-to-block)
- => (lambda (expected)
- (cond
- [(= expected 1)
- (void)]
- [else
- (fprintf op "~a.mvr=RT.si_context_expected(~a);\n"
- (munge-label-name (make-Label (LinkedLabel-label stmt)))
- expected)]))]
- [else
- (fprintf op "~a.mvr=~a;\n"
- (munge-label-name (make-Label (LinkedLabel-label stmt)))
- (assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))])
+ [(block-looks-like-context-expected-values? linked-to-block)
+ => (lambda (expected)
+ (cond
+ [(= expected 1)
+ (void)]
+ [else
+ (fprintf op "~a.mvr=RT.si_context_expected(~a);\n"
+ (munge-label-name (make-Label (LinkedLabel-label stmt)))
+ expected)]))]
+ [else
+ (fprintf op "~a.mvr=~a;\n"
+ (munge-label-name (make-Label (LinkedLabel-label stmt)))
+ (assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))])
(next)]
[(DebugPrint? stmt)
(next)]
@@ -197,26 +196,26 @@ 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)
(cond
- [(block-looks-like-context-expected-values? a-basic-block)
- =>
- (lambda (expected)
- (cond
- [(= expected 1)
- 'ok]
- [else
- (fprintf op "~a=RT.si_context_expected(~a);\n"
- (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
- expected)
- 'ok]))]
-
- [(block-looks-like-pop-multiple-values-and-continue? a-basic-block)
- =>
- (lambda (target)
- (fprintf op "~a=RT.si_pop_multiple-values-and-continue(~a);"
- (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
- target))]
- [else
- (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
+ [(block-looks-like-context-expected-values? a-basic-block)
+ =>
+ (lambda (expected)
+ (cond
+ [(= expected 1)
+ 'ok]
+ [else
+ (fprintf op "~a=RT.si_context_expected(~a);\n"
+ (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
+ expected)
+ 'ok]))]
+
+ [(block-looks-like-pop-multiple-values-and-continue? a-basic-block)
+ =>
+ (lambda (target)
+ (fprintf op "~a=RT.si_pop_multiple-values-and-continue(~a);"
+ (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
+ target))]
+ [else
+ (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
@@ -230,33 +229,33 @@ EOF
(define last-stmt
(last (BasicBlock-stmts a-basic-block)))
(cond
- [(Goto? last-stmt)
- (define target (Goto-target last-stmt))
- (equal? target (make-Label (BasicBlock-name a-basic-block)))]
- [else #f])]
+ [(Goto? last-stmt)
+ (define target (Goto-target last-stmt))
+ (equal? target (make-Label (BasicBlock-name a-basic-block)))]
+ [else #f])]
[else #f])))
(cond
- [is-self-looping?
- (fprintf op "while(true){")
- (when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
- (fprintf op "if(--M.cbt<0){throw ~a;}\n"
- (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
-
- (assemble-block-statements (BasicBlock-name a-basic-block)
- (drop-right (BasicBlock-stmts a-basic-block) 1)
- blockht
- entry-points
- op)
- (fprintf op "}")]
- [else
- (when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
- (fprintf op "if(--M.cbt<0){throw ~a;}\n"
- (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
- (assemble-block-statements (BasicBlock-name a-basic-block)
- (BasicBlock-stmts a-basic-block)
- blockht
- entry-points
- op)])
+ [is-self-looping?
+ (fprintf op "while(true){")
+ (when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
+ (fprintf op "if(--M.cbt<0){throw ~a;}\n"
+ (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
+
+ (assemble-block-statements (BasicBlock-name a-basic-block)
+ (drop-right (BasicBlock-stmts a-basic-block) 1)
+ blockht
+ entry-points
+ op)
+ (fprintf op "}")]
+ [else
+ (when (set-contains? function-entry-and-exit-names (BasicBlock-name a-basic-block))
+ (fprintf op "if(--M.cbt<0){throw ~a;}\n"
+ (assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht)))
+ (assemble-block-statements (BasicBlock-name a-basic-block)
+ (BasicBlock-stmts a-basic-block)
+ blockht
+ entry-points
+ op)])
(display "};\n" op)
'ok)
@@ -271,7 +270,7 @@ EOF
;(when (and (empty? (rest stmts))
; (not (Goto? stmt)))
; (log-debug (format "Last statement of the block ~a is not a goto" name)))
-
+
(display (assemble-statement stmt blockht) op)
(newline op)
(assemble-block-statements name
@@ -318,67 +317,67 @@ EOF
(format "if(~a===0)"
(assemble-oparg (TestZero-operand test)
blockht))]
-
+
[(TestClosureArityMismatch? test)
(format "if(!RT.isArityMatching((~a).racketArity,~a))"
(assemble-oparg (TestClosureArityMismatch-closure test)
blockht)
(assemble-oparg (TestClosureArityMismatch-n test)
blockht))]))
- (display test-code op)
- (display "{" op)
- (cond
- [(set-contains? entry-points (TestAndJump-label stmt))
- (display (assemble-jump (make-Label (TestAndJump-label stmt))
- blockht) op)]
- [else
- (assemble-block-statements (BasicBlock-name
- (hash-ref blockht (TestAndJump-label stmt)))
- (BasicBlock-stmts
- (hash-ref blockht (TestAndJump-label stmt)))
- blockht
- entry-points
- op)])
- (display "}else{" op)
- (assemble-block-statements name (rest stmts) blockht entry-points op)
- (display "}" op)
- 'ok]
+ (display test-code op)
+ (display "{" op)
+ (cond
+ [(set-contains? entry-points (TestAndJump-label stmt))
+ (display (assemble-jump (make-Label (TestAndJump-label stmt))
+ blockht) op)]
+ [else
+ (assemble-block-statements (BasicBlock-name
+ (hash-ref blockht (TestAndJump-label stmt)))
+ (BasicBlock-stmts
+ (hash-ref blockht (TestAndJump-label stmt)))
+ blockht
+ entry-points
+ op)])
+ (display "}else{" op)
+ (assemble-block-statements name (rest stmts) blockht entry-points op)
+ (display "}" op)
+ 'ok]
[(Goto? stmt)
(let loop ([stmt stmt])
(define target (Goto-target stmt))
(cond
- [(Label? target)
- (define target-block (hash-ref blockht (Label-name target)))
- (define target-name (BasicBlock-name target-block))
- (define target-statements (BasicBlock-stmts target-block))
- (cond
- ;; Optimization: if the target block consists of a single goto,
- ;; inline and follow the goto.
- [(and (not (empty? target-statements))
- (= 1 (length target-statements))
- (Goto? (first target-statements)))
- (loop (first target-statements))]
- [(set-contains? entry-points (Label-name target))
- (display (assemble-statement stmt blockht) op)
- 'ok]
- [else
- (log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
- (assemble-block-statements target-name
- target-statements
- blockht
- entry-points
- op)])]
- [(Reg? target)
- (display (assemble-statement stmt blockht) op)
- 'ok]
- [(ModuleEntry? target)
- (display (assemble-statement stmt blockht) op)
- 'ok]
- [(CompiledProcedureEntry? target)
- (display (assemble-statement stmt blockht) op)
- 'ok]))]
-
+ [(Label? target)
+ (define target-block (hash-ref blockht (Label-name target)))
+ (define target-name (BasicBlock-name target-block))
+ (define target-statements (BasicBlock-stmts target-block))
+ (cond
+ ;; Optimization: if the target block consists of a single goto,
+ ;; inline and follow the goto.
+ [(and (not (empty? target-statements))
+ (= 1 (length target-statements))
+ (Goto? (first target-statements)))
+ (loop (first target-statements))]
+ [(set-contains? entry-points (Label-name target))
+ (display (assemble-statement stmt blockht) op)
+ 'ok]
+ [else
+ (log-debug (format "Assembling inlined jump into ~a" (Label-name target)) )
+ (assemble-block-statements target-name
+ target-statements
+ blockht
+ entry-points
+ op)])]
+ [(Reg? target)
+ (display (assemble-statement stmt blockht) op)
+ 'ok]
+ [(ModuleEntry? target)
+ (display (assemble-statement stmt blockht) op)
+ 'ok]
+ [(CompiledProcedureEntry? target)
+ (display (assemble-statement stmt blockht) op)
+ 'ok]))]
+
[(PushControlFrame/Generic? stmt)
(default stmt)]
@@ -488,163 +487,162 @@ EOF
(define (assemble-statement stmt blockht)
(define assembled
(cond
- [(DebugPrint? stmt)
- (format "M.params.currentOutputPort.writeDomNode(M, $('').text(~a));"
- (assemble-oparg (DebugPrint-value stmt)
- blockht))]
- [(AssignImmediate? stmt)
- (let: ([t : (String -> String) (assemble-target (AssignImmediate-target stmt))]
- [v : OpArg (AssignImmediate-value stmt)])
- (t (assemble-oparg v blockht)))]
-
- [(AssignPrimOp? stmt)
- ((assemble-target (AssignPrimOp-target stmt))
- (assemble-op-expression (AssignPrimOp-op stmt)
+ [(DebugPrint? stmt)
+ (format "M.params.currentOutputPort.writeDomNode(M, $('').text(~a));"
+ (assemble-oparg (DebugPrint-value stmt)
blockht))]
-
- [(Perform? stmt)
- (assemble-op-statement (Perform-op stmt) blockht)]
-
- [(TestAndJump? stmt)
- (let*: ([test : PrimitiveTest (TestAndJump-op stmt)]
- [jump : String (assemble-jump
- (make-Label (TestAndJump-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)
- blockht)
- jump)]
- [(TestTrue? test)
- (format "if(~a!==false){~a}"
- (assemble-oparg (TestTrue-operand test)
- blockht)
- jump)]
- [(TestOne? test)
- (format "if(~a===1){~a}"
- (assemble-oparg (TestOne-operand test)
- blockht)
- jump)]
- [(TestZero? test)
- (format "if(~a===0){~a}"
- (assemble-oparg (TestZero-operand test)
- blockht)
- jump)]
- [(TestClosureArityMismatch? test)
- (format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
- (assemble-oparg (TestClosureArityMismatch-closure test)
- blockht)
- (assemble-oparg (TestClosureArityMismatch-n test)
- blockht)
- jump)])
- String))]
-
- [(Goto? stmt)
- (assemble-jump (Goto-target stmt)
- blockht)]
-
- [(PushControlFrame/Generic? stmt)
- "M.c.push(new RT.Frame());"]
-
- [(PushControlFrame/Call? stmt)
- (format "M.c.push(new RT.CallFrame(~a,M.p));"
- (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
- (cond
- [(symbol? label)
- (assemble-label (make-Label label)
- blockht)]
- [(LinkedLabel? label)
- (assemble-label (make-Label (LinkedLabel-label label))
- blockht)])))]
-
- [(PushControlFrame/Prompt? stmt)
- ;; fixme: use a different frame structure
- (format "M.c.push(new RT.PromptFrame(~a,~a));"
- (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
- (cond
- [(symbol? label)
- (assemble-label (make-Label label)
- blockht)]
- [(LinkedLabel? label)
- (assemble-label (make-Label (LinkedLabel-label label))
- blockht)]))
-
- (let: ([tag : (U DefaultContinuationPromptTag OpArg)
- (PushControlFrame/Prompt-tag stmt)])
- (cond
- [(DefaultContinuationPromptTag? tag)
- (assemble-default-continuation-prompt-tag)]
- [(OpArg? tag)
- (assemble-oparg tag blockht)])))]
-
- [(PopControlFrame? stmt)
- "M.c.pop();"]
-
- [(PushEnvironment? stmt)
- (cond [(= (PushEnvironment-n stmt) 0)
- ""]
- [(PushEnvironment-unbox? stmt)
- (format "M.e.push(~a);" (string-join
- (build-list (PushEnvironment-n stmt)
- (lambda: ([i : Natural])
- "[void(0)]"))
- ","))]
- [else
- (format "M.e.push(~a);" (string-join
- (build-list (PushEnvironment-n stmt)
- (lambda: ([i : Natural])
- "void(0)"))
- ","))
- ;(format "M.e.length+=~a;" (PushEnvironment-n stmt))
- ])]
- [(PopEnvironment? stmt)
- (let: ([skip : OpArg (PopEnvironment-skip stmt)])
- (cond
- [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
- (cond [(equal? (PopEnvironment-n stmt)
- (make-Const 1))
- "M.e.pop();"]
- [else
- (format "M.e.length-=~a;"
- (assemble-oparg (PopEnvironment-n stmt) blockht))])]
- [else
- (define skip (PopEnvironment-skip stmt))
- (define n (PopEnvironment-n stmt))
- (cond
- [(and (Const? skip) (Const? n))
- (format "M.e.splice(M.e.length-~a,~a);"
- (+ (ensure-natural (Const-const skip))
- (ensure-natural (Const-const n)))
- (Const-const n))]
- [else
- (format "M.e.splice(M.e.length-(~a+~a),~a);"
- (assemble-oparg skip blockht)
- (assemble-oparg n blockht)
- (assemble-oparg n blockht))])]))]
-
- [(PushImmediateOntoEnvironment? stmt)
- (format "M.e.push(~a);"
- (let: ([val-string : String
- (cond [(PushImmediateOntoEnvironment-box? stmt)
- (format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
- blockht))]
- [else
- (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
- blockht)])])
- val-string))]
- [(Comment? stmt)
- ;; TODO: maybe comments should be emitted as JavaScript comments.
- ""]))
+ [(AssignImmediate? stmt)
+ (let: ([t : (String -> String) (assemble-target (AssignImmediate-target stmt))]
+ [v : OpArg (AssignImmediate-value stmt)])
+ (t (assemble-oparg v blockht)))]
+
+ [(AssignPrimOp? stmt)
+ ((assemble-target (AssignPrimOp-target stmt))
+ (assemble-op-expression (AssignPrimOp-op stmt)
+ blockht))]
+
+ [(Perform? stmt)
+ (assemble-op-statement (Perform-op stmt) blockht)]
+
+ [(TestAndJump? stmt)
+ (let*: ([test : PrimitiveTest (TestAndJump-op stmt)]
+ [jump : String (assemble-jump
+ (make-Label (TestAndJump-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)
+ blockht)
+ jump)]
+ [(TestTrue? test)
+ (format "if(~a!==false){~a}"
+ (assemble-oparg (TestTrue-operand test)
+ blockht)
+ jump)]
+ [(TestOne? test)
+ (format "if(~a===1){~a}"
+ (assemble-oparg (TestOne-operand test)
+ blockht)
+ jump)]
+ [(TestZero? test)
+ (format "if(~a===0){~a}"
+ (assemble-oparg (TestZero-operand test)
+ blockht)
+ jump)]
+ [(TestClosureArityMismatch? test)
+ (format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
+ (assemble-oparg (TestClosureArityMismatch-closure test)
+ blockht)
+ (assemble-oparg (TestClosureArityMismatch-n test)
+ blockht)
+ jump)])
+ String))]
+
+ [(Goto? stmt)
+ (assemble-jump (Goto-target stmt)
+ blockht)]
+
+ [(PushControlFrame/Generic? stmt)
+ "M.c.push(new RT.Frame());"]
+
+ [(PushControlFrame/Call? stmt)
+ (format "M.c.push(new RT.CallFrame(~a,M.p));"
+ (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
+ (cond
+ [(symbol? label)
+ (assemble-label (make-Label label)
+ blockht)]
+ [(LinkedLabel? label)
+ (assemble-label (make-Label (LinkedLabel-label label))
+ blockht)])))]
+
+ [(PushControlFrame/Prompt? stmt)
+ ;; fixme: use a different frame structure
+ (format "M.c.push(new RT.PromptFrame(~a,~a));"
+ (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
+ (cond
+ [(symbol? label)
+ (assemble-label (make-Label label)
+ blockht)]
+ [(LinkedLabel? label)
+ (assemble-label (make-Label (LinkedLabel-label label))
+ blockht)]))
+
+ (let: ([tag : (U DefaultContinuationPromptTag OpArg)
+ (PushControlFrame/Prompt-tag stmt)])
+ (cond
+ [(DefaultContinuationPromptTag? tag)
+ (assemble-default-continuation-prompt-tag)]
+ [(OpArg? tag)
+ (assemble-oparg tag blockht)])))]
+
+ [(PopControlFrame? stmt)
+ "M.c.pop();"]
+
+ [(PushEnvironment? stmt)
+ (cond [(= (PushEnvironment-n stmt) 0)
+ ""]
+ [(PushEnvironment-unbox? stmt)
+ (format "M.e.push(~a);" (string-join
+ (build-list (PushEnvironment-n stmt)
+ (lambda: ([i : Natural])
+ "[void(0)]"))
+ ","))]
+ [else
+ (format "M.e.push(~a);" (string-join
+ (build-list (PushEnvironment-n stmt)
+ (lambda: ([i : Natural])
+ "void(0)"))
+ ","))
+ ;(format "M.e.length+=~a;" (PushEnvironment-n stmt))
+ ])]
+ [(PopEnvironment? stmt)
+ (let: ([skip : OpArg (PopEnvironment-skip stmt)])
+ (cond
+ [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
+ (cond [(equal? (PopEnvironment-n stmt)
+ (make-Const 1))
+ "M.e.pop();"]
+ [else
+ (format "M.e.length-=~a;"
+ (assemble-oparg (PopEnvironment-n stmt) blockht))])]
+ [else
+ (define skip (PopEnvironment-skip stmt))
+ (define n (PopEnvironment-n stmt))
+ (cond
+ [(and (Const? skip) (Const? n))
+ (format "M.e.splice(M.e.length-~a,~a);"
+ (+ (ensure-natural (Const-const skip))
+ (ensure-natural (Const-const n)))
+ (Const-const n))]
+ [else
+ (format "M.e.splice(M.e.length-(~a+~a),~a);"
+ (assemble-oparg skip blockht)
+ (assemble-oparg n blockht)
+ (assemble-oparg n blockht))])]))]
+
+ [(PushImmediateOntoEnvironment? stmt)
+ (format "M.e.push(~a);"
+ (let: ([val-string : String
+ (cond [(PushImmediateOntoEnvironment-box? stmt)
+ (format "[~a]" (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
+ blockht))]
+ [else
+ (assemble-oparg (PushImmediateOntoEnvironment-value stmt)
+ blockht)])])
+ val-string))]
+ [(Comment? stmt)
+ (format "//~s\n" (Comment-val stmt))]))
(cond
- #;[(current-emit-debug-trace?)
- (string-append
- (format "if(window.console!==void(0)&&typeof(window.console.log)==='function'){window.console.log(~s);\n}"
- (format "~a" stmt))
- assembled)]
- [else
- assembled]))
+ [emit-debug-trace?
+ (string-append
+ (format "if(window.console!==void(0)&&typeof(window.console.log)==='function'){window.console.log(~s);\n}"
+ (format "~a" stmt))
+ assembled)]
+ [else
+ assembled]))
(define-predicate natural? Natural)
@@ -660,25 +658,25 @@ EOF
(: get-function-entry-and-exit-names ((Listof Statement) -> (Listof Symbol)))
(define (get-function-entry-and-exit-names stmts)
(cond
- [(empty? stmts)
- '()]
- [else
- (define first-stmt (first stmts))
- (cond
- [(LinkedLabel? first-stmt)
- (cons (LinkedLabel-label first-stmt)
- (cons (LinkedLabel-linked-to first-stmt)
- (get-function-entry-and-exit-names (rest stmts))))]
- [(AssignPrimOp? first-stmt)
- (define op (AssignPrimOp-op first-stmt))
- (cond
- [(MakeCompiledProcedure? op)
- (cons (MakeCompiledProcedure-label op)
- (get-function-entry-and-exit-names (rest stmts)))]
- [(MakeCompiledProcedureShell? first-stmt)
- (cons (MakeCompiledProcedureShell-label op)
- (get-function-entry-and-exit-names (rest stmts)))]
+ [(empty? stmts)
+ '()]
+ [else
+ (define first-stmt (first stmts))
+ (cond
+ [(LinkedLabel? first-stmt)
+ (cons (LinkedLabel-label first-stmt)
+ (cons (LinkedLabel-linked-to first-stmt)
+ (get-function-entry-and-exit-names (rest stmts))))]
+ [(AssignPrimOp? first-stmt)
+ (define op (AssignPrimOp-op first-stmt))
+ (cond
+ [(MakeCompiledProcedure? op)
+ (cons (MakeCompiledProcedure-label op)
+ (get-function-entry-and-exit-names (rest stmts)))]
+ [(MakeCompiledProcedureShell? first-stmt)
+ (cons (MakeCompiledProcedureShell-label op)
+ (get-function-entry-and-exit-names (rest stmts)))]
+ [else
+ (get-function-entry-and-exit-names (rest stmts))])]
[else
- (get-function-entry-and-exit-names (rest stmts))])]
- [else
- (get-function-entry-and-exit-names (rest stmts))])]))
+ (get-function-entry-and-exit-names (rest stmts))])]))
diff --git a/version.rkt b/version.rkt
index a4056e4..d12d1ca 100644
--- a/version.rkt
+++ b/version.rkt
@@ -7,4 +7,4 @@
(provide version)
(: version String)
-(define version "1.195")
+(define version "1.198")