lifting up closure constants
This commit is contained in:
Danny Yoo
parent
0ad456d380
commit
cd7b8904f5
|
|
@ -7,10 +7,31 @@
|
|||
"../compiler/il-structs.rkt"
|
||||
racket/string)
|
||||
|
||||
(provide assemble-op-expression)
|
||||
(provide assemble-op-expression
|
||||
current-interned-constant-closure-table
|
||||
assemble-current-interned-constant-closure-table)
|
||||
|
||||
|
||||
|
||||
|
||||
(: current-interned-constant-closure-table (Parameterof (HashTable Symbol MakeCompiledProcedure)))
|
||||
(define current-interned-constant-closure-table
|
||||
(make-parameter ((inst make-hasheq Symbol MakeCompiledProcedure))))
|
||||
|
||||
|
||||
(: assemble-current-interned-constant-closure-table (-> String))
|
||||
(define (assemble-current-interned-constant-closure-table)
|
||||
(string-join (hash-map
|
||||
(current-interned-constant-closure-table)
|
||||
(lambda: ([a-label : Symbol] [a-shell : MakeCompiledProcedure])
|
||||
(format "var ~a_c=new RT.Closure(~a,~a,void(0),~a);"
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label a-shell)))
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label a-shell)))
|
||||
(assemble-arity (MakeCompiledProcedure-arity a-shell))
|
||||
(assemble-display-name (MakeCompiledProcedure-display-name a-shell)))))
|
||||
"\n"))
|
||||
|
||||
|
||||
(: assemble-op-expression (PrimitiveOperator Blockht -> String))
|
||||
(define (assemble-op-expression op blockht)
|
||||
(cond
|
||||
|
|
@ -20,17 +41,17 @@
|
|||
[(MakeCompiledProcedure? op)
|
||||
(cond
|
||||
;; Small optimization: try to avoid creating the array if we know up front
|
||||
;; that the closure has no closed values.
|
||||
;; that the closure has no closed values. It's a constant that we lift up to the toplevel.
|
||||
[(null? (MakeCompiledProcedure-closed-vals op))
|
||||
(format "new RT.Closure(~a,~a,void(0),~a)"
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label op))
|
||||
blockht)
|
||||
(assemble-arity (MakeCompiledProcedure-arity op))
|
||||
(assemble-display-name (MakeCompiledProcedure-display-name op)))]
|
||||
(define assembled-label (assemble-label (make-Label (MakeCompiledProcedure-label op))))
|
||||
(unless (hash-has-key? (current-interned-constant-closure-table) (MakeCompiledProcedure-label op))
|
||||
(hash-set! (current-interned-constant-closure-table)
|
||||
(MakeCompiledProcedure-label op)
|
||||
op))
|
||||
(format "~a_c" assembled-label)]
|
||||
[else
|
||||
(format "new RT.Closure(~a,~a,[~a],~a)"
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label op))
|
||||
blockht)
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label op)))
|
||||
(assemble-arity (MakeCompiledProcedure-arity op))
|
||||
(string-join (map
|
||||
assemble-env-reference/closure-capture
|
||||
|
|
@ -44,8 +65,7 @@
|
|||
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(format "new RT.Closure(~a,~a,void(0),~a)"
|
||||
(assemble-label (make-Label (MakeCompiledProcedureShell-label op))
|
||||
blockht)
|
||||
(assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
|
||||
(assemble-arity (MakeCompiledProcedureShell-arity op))
|
||||
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@
|
|||
[(Reg? v)
|
||||
(assemble-reg v)]
|
||||
[(Label? v)
|
||||
(assemble-label v blockht)]
|
||||
(assemble-label v)]
|
||||
[(Const? v)
|
||||
(assemble-const v)]
|
||||
[(EnvLexicalReference? v)
|
||||
|
|
@ -335,8 +335,8 @@
|
|||
|
||||
|
||||
|
||||
(: assemble-label (Label Blockht -> String))
|
||||
(define (assemble-label a-label Blockht)
|
||||
(: assemble-label (Label -> String))
|
||||
(define (assemble-label a-label)
|
||||
(munge-label-name a-label))
|
||||
|
||||
|
||||
|
|
@ -479,7 +479,7 @@
|
|||
[(Reg? a-location)
|
||||
(assemble-reg a-location)]
|
||||
[(Label? a-location)
|
||||
(assemble-label a-location blockht)]))
|
||||
(assemble-label a-location)]))
|
||||
|
||||
|
||||
(: assemble-primitive-kernel-value (PrimitiveKernelValue -> String))
|
||||
|
|
|
|||
|
|
@ -156,8 +156,7 @@
|
|||
(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))
|
||||
blockht))]
|
||||
(assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]
|
||||
|
||||
[(MarkModuleInvoked!? op)
|
||||
(format "M.modules[~s].isInvoked=true;"
|
||||
|
|
|
|||
|
|
@ -36,7 +36,8 @@
|
|||
;; What's emitted is a function expression that, when invoked, runs the
|
||||
;; statements.
|
||||
(define (assemble/write-invoke stmts op)
|
||||
(parameterize ([current-interned-symbol-table ((inst make-hash Symbol Symbol))])
|
||||
(parameterize ([current-interned-symbol-table ((inst make-hash Symbol Symbol))]
|
||||
[current-interned-constant-closure-table ((inst make-hash Symbol MakeCompiledProcedure))])
|
||||
(display "(function(M, success, fail, params) {\n" op)
|
||||
(display "var param;\n" op)
|
||||
(display "var RT = plt.runtime;\n" op)
|
||||
|
|
@ -59,6 +60,7 @@
|
|||
op)
|
||||
(write-linked-label-attributes stmts blockht op)
|
||||
(display (assemble-current-interned-symbol-table) op)
|
||||
(display (assemble-current-interned-constant-closure-table) op)
|
||||
|
||||
(display "M.params.currentErrorHandler = fail;\n" op)
|
||||
(display "M.params.currentSuccessHandler = success;\n" op)
|
||||
|
|
@ -71,8 +73,7 @@ for (param in params) {
|
|||
EOF
|
||||
op)
|
||||
(fprintf op "M.trampoline(~a, true); })"
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))
|
||||
blockht))))
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -158,7 +159,7 @@ EOF
|
|||
[else
|
||||
(fprintf op "~a.mvr=~a;\n"
|
||||
(munge-label-name (make-Label (LinkedLabel-label stmt)))
|
||||
(assemble-label (make-Label (LinkedLabel-linked-to stmt)) blockht))])
|
||||
(assemble-label (make-Label (LinkedLabel-linked-to stmt))))])
|
||||
(next)]
|
||||
[(DebugPrint? stmt)
|
||||
(next)]
|
||||
|
|
@ -223,7 +224,7 @@ EOF
|
|||
(: default-assemble-basic-block (BasicBlock Blockht (Setof Symbol) (Setof Symbol) Output-Port -> 'ok))
|
||||
(define (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)
|
||||
(fprintf op "var ~a=function(M){"
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)) blockht))
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block))))
|
||||
(define is-self-looping?
|
||||
(let ()
|
||||
(cond [(not (empty? (BasicBlock-stmts a-basic-block)))
|
||||
|
|
@ -240,7 +241,7 @@ EOF
|
|||
(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-label (make-Label (BasicBlock-name a-basic-block)))))
|
||||
|
||||
(assemble-block-statements (BasicBlock-name a-basic-block)
|
||||
(drop-right (BasicBlock-stmts a-basic-block) 1)
|
||||
|
|
@ -251,7 +252,7 @@ EOF
|
|||
[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-label (make-Label (BasicBlock-name a-basic-block)))))
|
||||
(assemble-block-statements (BasicBlock-name a-basic-block)
|
||||
(BasicBlock-stmts a-basic-block)
|
||||
blockht
|
||||
|
|
@ -553,11 +554,9 @@ EOF
|
|||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
(assemble-label (make-Label label))]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)])))]
|
||||
(assemble-label (make-Label (LinkedLabel-label label)))])))]
|
||||
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
;; fixme: use a different frame structure
|
||||
|
|
@ -565,11 +564,9 @@ EOF
|
|||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
|
||||
(cond
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label)
|
||||
blockht)]
|
||||
(assemble-label (make-Label label))]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label))
|
||||
blockht)]))
|
||||
(assemble-label (make-Label (LinkedLabel-label label)))]))
|
||||
|
||||
(let: ([tag : (U DefaultContinuationPromptTag OpArg)
|
||||
(PushControlFrame/Prompt-tag stmt)])
|
||||
|
|
|
|||
|
|
@ -7,4 +7,4 @@
|
|||
(provide version)
|
||||
(: version String)
|
||||
|
||||
(define version "1.215")
|
||||
(define version "1.218")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user