diff --git a/js-assembler/assemble-expression.rkt b/js-assembler/assemble-expression.rkt index 9341ac8..481e4f3 100644 --- a/js-assembler/assemble-expression.rkt +++ b/js-assembler/assemble-expression.rkt @@ -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)))] diff --git a/js-assembler/assemble-helpers.rkt b/js-assembler/assemble-helpers.rkt index c9c6a1c..1271dc6 100644 --- a/js-assembler/assemble-helpers.rkt +++ b/js-assembler/assemble-helpers.rkt @@ -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)) diff --git a/js-assembler/assemble-perform-statement.rkt b/js-assembler/assemble-perform-statement.rkt index bec15f7..305b85c 100644 --- a/js-assembler/assemble-perform-statement.rkt +++ b/js-assembler/assemble-perform-statement.rkt @@ -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;" diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt index fac0fb7..fc93569 100644 --- a/js-assembler/assemble.rkt +++ b/js-assembler/assemble.rkt @@ -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)]) diff --git a/version.rkt b/version.rkt index 3e24b9d..cca1635 100644 --- a/version.rkt +++ b/version.rkt @@ -7,4 +7,4 @@ (provide version) (: version String) -(define version "1.215") +(define version "1.218")