working on block optimization

js-assembler/optimize-basic-blocks.rkt

@@ -1,9 +1,13 @@
 #lang typed/racket/base
 
+;; Does some basic optimizations at the level of basic blocks.
+
+
 (require "assemble-structs.rkt"
          "../compiler/il-structs.rkt"
          racket/list)
 
+
 (require/typed "../logger.rkt" [log-debug (String -> Void)])
 
 
@@ -11,18 +15,29 @@
 
 
 (define-type Blockht (HashTable Symbol BasicBlock))
+(define-type Bodyht (HashTable (Listof UnlabeledStatement) Symbol))
 
 
 (: optimize-basic-blocks ((Listof BasicBlock) -> (Listof BasicBlock)))
 (define (optimize-basic-blocks blocks)
-  (let: ([blockht : Blockht (make-hasheq)])
-    (for-each (lambda: ([b : BasicBlock])
-                       (hash-set! blockht (BasicBlock-name b) b))
-              blocks)
 
+  (: blockht : Blockht)
+  (define blockht (make-hasheq))
+
+  (: bodyht : Blockht)
+  (define bodyht (make-hasheq))
+
+  (for ([b blocks])
+       (hash-set! blockht (BasicBlock-name b) b))
+
+  
+  
+  (define inlined-blocks
     (map (lambda: ([b : BasicBlock])
-           (optimize-block b blockht))
-         blocks)))
+                  (optimize-block b blockht))
+         blocks))
+  
+  inlined-blocks)
 
 
 
@@ -31,23 +46,23 @@
 ;; Simple optimization: optimize away single-statement goto blocks with their
 ;; immediate contents.
 (define (optimize-block b blocks)
-  (let ([stmts (BasicBlock-stmts b)])
+  (define stmts (BasicBlock-stmts b))
+  (cond
+   [(= (length stmts) 1)
+    (define first-stmt (first stmts))
     (cond
-     [(= (length stmts) 1)
-      (let ([first-stmt (first stmts)])
-        (cond
-         [(GotoStatement? first-stmt)
-          (let ([target (GotoStatement-target first-stmt)])
-            (cond
-             [(Label? target)
-              (log-debug (format "inlining basic block ~a" (BasicBlock-name b)))
-              (optimize-block (make-BasicBlock (BasicBlock-name b)
-                                                (BasicBlock-stmts
-                                                 (hash-ref blocks (Label-name target))))
-                               blocks)]
-             [else
-              b]))]
-         [else
-          b]))]
+     [(GotoStatement? first-stmt)
+      (define target (GotoStatement-target first-stmt)) 
+      (cond
+       [(Label? target)
+        (log-debug (format "inlining basic block ~a" (BasicBlock-name b)))
+        (optimize-block (make-BasicBlock (BasicBlock-name b)
+                                         (BasicBlock-stmts
+                                          (hash-ref blocks (Label-name target))))
+                        blocks)]
+       [else
+        b])]
      [else
-      b])))
+      b])]
+   [else
+    b]))

tests/more-tests/simple-functions.expected

@@ -0,0 +1,3 @@
+1
+2
+68

tests/more-tests/simple-functions.rkt

@@ -0,0 +1,10 @@
+#lang planet dyoo/whalesong
+(define (f x)
+  (* x x))
+
+(define (g x)
+  (+ x x))
+
+(f 1)
+(g 1)
+(+ (f 2) (f (g (g 2))))

tests/run-more-tests.rkt

@@ -7,7 +7,7 @@
 ;; type replaced with .expected.
 
 (test "more-tests/hello.rkt")
-(test "more-tests/conform.rkt")
+(test "more-tests/simple-functions.rkt")
 (test "more-tests/sk-generator.rkt")
 (test "more-tests/sk-generator-2.rkt")
 (test "more-tests/simple-structs.rkt")
@@ -15,6 +15,7 @@
 (test "more-tests/colors.rkt")
 (test "more-tests/images.rkt")
 (test "more-tests/lists.rkt")
-(test "more-tests/earley.rkt")
-(test "more-tests/hello-bf.rkt")
 (test "more-tests/simple-apply.rkt")
+(test "more-tests/hello-bf.rkt")
+(test "more-tests/conform.rkt")
+(test "more-tests/earley.rkt")