lifting up closure constants

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)"
+       (define assembled-label (assemble-label (make-Label (MakeCompiledProcedure-label op))))
-               (assemble-label (make-Label (MakeCompiledProcedure-label op))
+       (unless (hash-has-key? (current-interned-constant-closure-table) (MakeCompiledProcedure-label op))
-                               blockht)
+         (hash-set! (current-interned-constant-closure-table)
-               (assemble-arity (MakeCompiledProcedure-arity op))
+                    (MakeCompiledProcedure-label op)
-               (assemble-display-name (MakeCompiledProcedure-display-name op)))]
+                    op))
+       (format "~a_c" assembled-label)]
       [else
        (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 
@@ -44,8 +65,7 @@
     
     [(MakeCompiledProcedureShell? op)
      (format "new RT.Closure(~a,~a,void(0),~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)))]
     

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))
+(: assemble-label (Label -> String))
-(define (assemble-label a-label Blockht)
+(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))

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))
+             (assemble-label (make-Label (InstallModuleEntry!-entry-point op))))]
-                             blockht))]
 
     [(MarkModuleInvoked!? op)
      (format "M.modules[~s].isInvoked=true;"

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)))
+           (assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))))
-                           blockht))))
 
 
 
@@ -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)
+                    (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
@@ -565,11 +564,9 @@ 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)])

version.rkt

@@ -7,4 +7,4 @@
 (provide version)
 (: version String)
 
-(define version "1.215")
+(define version "1.218")