reducing cost of fracture by using hashtable

js-assembler/collect-jump-targets.rkt

@@ -128,40 +128,13 @@
       [(InstallModuleEntry!? op)
        (list (InstallModuleEntry!-entry-point op))]
       [else
-       empty]
+       empty]))
-      ;; currently written this way because I'm hitting some bad type-checking behavior.
-      #;([(CheckToplevelBound!? op)
-          empty]
-         [(CheckClosureArity!? op)
-          empty]
-         [(CheckPrimitiveArity!? op)
-          empty]
-         [(ExtendEnvironment/Prefix!? op)
-          empty]
-         [(InstallClosureValues!? op)
-          empty]
-         [(RestoreEnvironment!? op)
-          empty]
-         [(RestoreControl!? op)
-          empty]
-         [(SetFrameCallee!? op)
-          empty]
-         [(SpliceListIntoStack!? op)
-          empty]
-         [(UnspliceRestFromStack!? op)
-          empty]
-         [(FixClosureShellMap!? op)
-          empty]
-         [(InstallContinuationMarkEntry!? op)
-          empty]
-         [(RaiseContextExpectedValuesError!? op)
-          empty]
-         [(RaiseArityMismatchError!? op)
-          empty]
-         [(RaiseOperatorApplicationError!? op)
-          empty])))
   
+  (: start-time Real)
+  (define start-time (current-inexact-milliseconds))
 
+  (: result (Listof Symbol))
+  (define result
     (unique/eq?
      (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
        (cond [(empty? stmts)
@@ -171,6 +144,12 @@
                 (append (collect-statement stmt)
                         (loop (rest stmts))))]))))
 
+  (: end-time Real)
+  (define end-time (current-inexact-milliseconds))
+  (printf "  collect-general-jump-targets: ~a milliseconds\n" (- end-time start-time))
+  result)
+
+
 
 
 

js-assembler/fracture.rkt

@@ -22,10 +22,15 @@
 
 
 
+
 ;; fracture: (listof stmt) -> (listof basic-block)
 (: fracture ((Listof Statement) -> (values (Listof BasicBlock)
                                            (Listof Symbol))))
 (define (fracture stmts)
+
+  (define start-time (current-inexact-milliseconds))
+      
+  (define-values (blocks entries)
     (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
                                                  (symbol? (first stmts)))
                                             (first stmts)
@@ -38,6 +43,12 @@
                           (cons first-block-label (collect-general-jump-targets stmts))]
             [entry-points : (Listof Symbol)
                           (cons first-block-label (collect-entry-points stmts))])
+
+      (define jump-targets-ht ((inst make-hasheq Symbol Boolean)))
+      (for ([name jump-targets])
+           (hash-set! jump-targets-ht name #t))
+
+      (set! start-time (current-inexact-milliseconds))
       (let: loop : (values (Listof BasicBlock) (Listof Symbol))
             ([name : Symbol first-block-label]
              [acc : (Listof UnlabeledStatement) '()]
@@ -54,14 +65,14 @@
             (: do-on-label (Symbol -> (values (Listof BasicBlock) (Listof Symbol))))
             (define (do-on-label label-name)
               (cond
-               [(member label-name jump-targets)
+               [(hash-has-key? jump-targets-ht label-name)
                 (loop label-name
                       '()
                       (cons (make-BasicBlock 
                              name  
                              (if last-stmt-goto? 
                                  (reverse acc)
-                                 (reverse (append `(,(make-GotoStatement (make-Label label-name)))
+                                 (reverse (cons (make-GotoStatement (make-Label label-name))
                                                 acc))))
                             basic-blocks)
                       (cdr stmts)
@@ -83,3 +94,8 @@
                     basic-blocks
                     (cdr stmts)
                     (GotoStatement? (car stmts)))]))]))))
+
+  (define end-time (current-inexact-milliseconds))
+  (printf "  assemble fracture: ~a milliseconds\n" (- end-time start-time))
+
+  (values blocks entries))

js-assembler/package.rkt

@@ -253,7 +253,6 @@ MACHINE.modules[~s] =
       (fprintf temporary-output-port "(MACHINE, function() { ")])
     (define stop-time (current-inexact-milliseconds))
     (printf "  assembly: ~s milliseconds\n" (- stop-time start-time))
-    (displayln (bytes-length (get-output-bytes temporary-output-port)))
     (write-bytes (get-output-bytes temporary-output-port) op)
     (void))
   

make/make.rkt

@@ -66,7 +66,7 @@
       (define start-time (current-inexact-milliseconds))
       (define compiled-code (compile ast 'val next-linkage/drop-multiple))
       (define stop-time (current-inexact-milliseconds))
-      (printf "  compile ast: ~a milliseconds\n" (- stop-time start-time))
+      ;(printf "  compile ast: ~a milliseconds\n" (- stop-time start-time))
       (values ast compiled-code))]))