Branch hoisting work in progress

core/compiler/tests/stack-trace.factor

@@ -1,7 +1,7 @@
 IN: temporary
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
-words splitting ;
+words splitting sorting ;
 
 : symbolic-stack-trace ( -- newseq )
     error-continuation get continuation-call callstack>array
@@ -31,9 +31,9 @@ words splitting ;
     \ > stack-trace-contains?
 ] unit-test
 
-: quux [ t [ "hi" throw ] when ] times ;
+: quux { 1 2 3 } [ "hi" throw ] sort ;
 
 [ t ] [
     [ 10 quux ] ignore-errors
-    \ (each-integer) stack-trace-contains?
+    \ sort stack-trace-contains?
 ] unit-test

core/compiler/tests/templates-early.factor

@@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
 [
     [ ] [ init-templates ] unit-test
 
-    [ ] [ init-generator ] unit-test
+    H{ } clone compiled set
+
+    [ ] [ gensym gensym begin-compiling ] unit-test
 
     [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
 

core/optimizer/backend/backend.factor

@@ -176,23 +176,71 @@ M: node remember-method*
         } cond
     ] if ;
 
+: fold-if-branch? dup node-in-d first known-boolean-value? ;
+
+: fold-if-branch ( node value -- node' )
+    over drop-inputs >r
+    0 1 ? fold-branch
+    r> [ set-node-successor ] keep ;
+
+: only-one ( seq -- elt/f )
+    dup length 1 = [ first ] [ drop f ] if ;
+
+: lift-throw-tail? ( #if -- tail/? )
+    dup node-successor node-successor
+    [ active-children only-one ] [ drop f ] if ;
+
+: clone-node ( node -- newnode )
+    clone dup [ clone ] modify-values ;
+
+: lift-branch ( #if node -- )
+    over last-node clone-node -rot
+    >r dup node-successor r> substitute-node
+    set-node-successor ;
+
 M: #if optimize-node*
-    dup dup node-in-d first known-boolean-value? [
-        over drop-inputs >r
-        0 1 ? fold-branch
-        r> [ set-node-successor ] keep
-        t
-    ] [ 2drop t f ] if ;
+    dup fold-if-branch? [ fold-if-branch t ] [
+        drop dup lift-throw-tail? dup [
+            dupd lift-branch t
+        ] [
+            2drop t f
+        ] if
+    ] if ;
+
+: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
+
+: fold-dispatch-branch ( node value -- node' )
+    dupd node-literal
+    over drop-inputs >r fold-branch r>
+    [ set-node-successor ] keep ;
 
 M: #dispatch optimize-node*
-    dup dup node-in-d first 2dup node-literal? [
-        "Optimizing #dispatch" print
-        node-literal
-        over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
+    dup fold-dispatch-branch? [
+        fold-dispatch-branch t
     ] [
-        3drop t f
+        2drop t f
     ] if ;
 
+! #loop
+: lift-loop-tail? ( #label -- tail/f )
+    dup node-child dup #if? [
+        node-children
+        [ penultimate-node ] map
+        [
+            dup #call-label?
+            [ node-param eq? not ] [ 2drop t ] if
+        ] with subset only-one
+    ] [
+        2drop f
+    ] if ;
+
+! M: #loop optimize-node*
+!     dup lift-loop-tail? dup [
+!         over node-child swap lift-branch t
+!     ] [
+!         2drop t f
+!     ] if ;
+
 ! #call
 : splice-method ( #call method-spec/t quot/t -- node/t )
     #! t indicates failure

core/optimizer/def-use/def-use.factor

@@ -70,20 +70,6 @@ M: #branch node-def-use
     #! #values node.
     dup branch-def-use (node-def-use) ;
 
-! : dead-literals ( -- values )
-!     def-use get [ >r value? r> empty? and ] assoc-subset ;
-! 
-! : kill-node* ( node values -- )
-!     [ swap remove-all ] curry modify-values ;
-! 
-! : kill-node ( node values -- )
-!     dup assoc-empty?
-!     [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
-! 
-! : kill-values ( node -- )
-!     #! Remove literals which are not actually used anywhere.
-!     dead-literals kill-node ;
-
 : compute-dead-literals ( -- values )
     def-use get [ >r value? r> empty? and ] assoc-subset ;
 
@@ -129,8 +115,6 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
         dead-literals [ kill-nodes ] with-variable
     ] if ;
 
-!
-
 : sole-consumer ( #call -- node/f )
     node-out-d first used-by
     dup length 1 = [ first ] [ drop f ] if ;

core/optimizer/specializers/specializers.factor

@@ -24,7 +24,7 @@ IN: optimizer.specializers
         \ dispatch ,
     ] [ ] make ;
 
-: specializer-methods ( word -- alist )
+: specializer-methods ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
         [ declare ] curry pick append