enable-compiler and disable-compiler words

core/bootstrap/compiler/compiler.factor

@@ -74,6 +74,12 @@ nl
     malloc free memcpy
 } compile
 
-[ compiled-usages recompile ] recompile-hook set-global
+: enable-compiler ( -- )
+    [ compiled-usages recompile ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+    [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
+
+enable-compiler
 
 " done" print flush

core/inference/dataflow/dataflow.factor

@@ -314,7 +314,7 @@ PREDICATE: #merge #tail-merge node-successor #tail? ;
 PREDICATE: #values #tail-values node-successor #tail? ;
 
 UNION: #tail
-    POSTPONE: f #return #tail-values #tail-merge ;
+    POSTPONE: f #return #tail-values #tail-merge #terminate ;
 
 : tail-call? ( -- ? )
     node-stack get [ node-successor #tail? ] all? ;

core/optimizer/backend/backend.factor

@@ -68,8 +68,6 @@ DEFER: optimize-nodes
         ] if
     ] when ;
 
-M: f set-node-successor 2drop ;
-
 : optimize-nodes ( node -- newnode )
     [
         class-substitutions [ clone ] change
@@ -81,16 +79,7 @@ M: f set-node-successor 2drop ;
 ! Generic nodes
 M: node optimize-node* drop t f ;
 
-: cleanup-inlining ( node -- newnode changed? )
+! Post-inlining cleanup
-    node-successor [ node-successor t ] [ t f ] if* ;
-
-! #return
-M: #return optimize-node* cleanup-inlining ;
-
-! #values
-M: #values optimize-node* cleanup-inlining ;
-
-! Some utilities for splicing in dataflow IR subtrees
 : follow ( key assoc -- value )
     2dup at* [ swap follow nip ] [ 2drop ] if ;
 
@@ -103,32 +92,31 @@ M: #values optimize-node* cleanup-inlining ;
     #! Not very efficient.
     dupd union* update ;
 
-: post-inline ( #call/#merge #return/#values -- assoc )
+: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
-    >r node-out-d r> node-in-d 2array unify-lengths flip
+    node-out-d swap node-in-d 2array unify-lengths flip
     [ = not ] assoc-subset >hashtable ;
 
-: substitute-def-use ( node -- )
+: cleanup-inlining ( #return/#values -- newnode changed? )
-    #! As a first approximation, we take all the values used
+    dup node-successor dup [
-    #! by the set of new nodes, and push a 't' on their
+        class-substitutions get pick node-classes update
-    #! def-use list here. We could perform a full graph
+        literal-substitutions get pick node-literals update
-    #! substitution, but we don't need to, because the next
+        tuck compute-value-substitutions value-substitutions get swap update*
-    #! optimizer iteration will do that. We just need a minimal
+        node-successor t
-    #! degree of accuracy; the new values should be marked as
+    ] [
-    #! having _some_ usage, so that flushing doesn't erronously
+        2drop t f
-    #! flush them away.
+    ] if ;
-    [ compute-def-use def-use get keys ] with-scope
-    def-use get [ [ t swap ?push ] change-at ] curry each ;
 
-: substitute-node ( old new -- )
+! #return
-    #! The last node of 'new' becomes 'old', then values are
+M: #return optimize-node* cleanup-inlining ;
-    #! substituted. A subsequent optimizer phase kills the
+
-    #! last node of 'new' and the first node of 'old'.
+! #values
-    dup substitute-def-use
+M: #values optimize-node* cleanup-inlining ;
-    last-node
+
-    class-substitutions get over node-classes update
+! Some utilities for splicing in dataflow IR subtrees
-    literal-substitutions get over node-literals update
+M: f set-node-successor 2drop ;
-    2dup post-inline value-substitutions get swap update*
+
-    set-node-successor ;
+: splice-node ( old new -- )
+    dup splice-def-use last-node set-node-successor ;
 
 GENERIC: remember-method* ( method-spec node -- )
 
@@ -148,12 +136,12 @@ M: node remember-method*
     pick node-in-d dataflow-with
     [ remember-method ] keep
     [ swap infer-classes/node ] 2keep
-    [ substitute-node ] keep ;
+    [ splice-node ] keep ;
 
 : splice-quot ( #call quot -- node )
     over node-in-d dataflow-with
     [ swap infer-classes/node ] 2keep
-    [ substitute-node ] keep ;
+    [ splice-node ] keep ;
 
 : drop-inputs ( node -- #shuffle )
     node-in-d clone \ #shuffle in-node ;
@@ -161,7 +149,7 @@ M: node remember-method*
 ! Constant branch folding
 : fold-branch ( node branch# -- node )
     over node-children nth
-    swap node-successor over substitute-node ;
+    swap node-successor over splice-node ;
 
 ! #if
 : known-boolean-value? ( node value -- value ? )
@@ -193,18 +181,20 @@ M: node remember-method*
 : clone-node ( node -- newnode )
     clone dup [ clone ] modify-values ;
 
+: detach-node-successor ( node -- successor )
+    dup node-successor #terminate rot set-node-successor ;
+
 : lift-branch ( #if node -- )
-    over last-node clone-node -rot
+    >r detach-node-successor r> splice-node ;
-    >r dup node-successor r> substitute-node
-    set-node-successor ;
 
 M: #if optimize-node*
     dup fold-if-branch? [ fold-if-branch t ] [
-        drop dup lift-throw-tail? dup [
+        2drop t f
-            dupd lift-branch t
+        ! drop dup lift-throw-tail? dup [
-        ] [
+        !     dupd lift-branch t
-            2drop t f
+        ! ] [
-        ] if
+        !     2drop t f
+        ! ] if
     ] if ;
 
 : fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
@@ -222,21 +212,72 @@ M: #dispatch optimize-node*
     ] if ;
 
 ! #loop
+
+
+! BEFORE:
+
+!   #label -> C -> #return 1
+!     |
+!     -> #if -> #merge -> #return 2
+!         |
+!     --------
+!     |      |
+!     A      B
+!     |      |
+!  #values   |
+!        #call-label
+!            |
+!            |
+!         #values
+
+! AFTER:
+
+!    #label -> #terminate
+!     |
+!     -> #if -> #terminate
+!         |
+!     --------
+!     |      |
+!     A      B
+!     |      |
+!  #values   |
+!     |  #call-label
+!  #merge    |
+!     |      |
+!     C   #values
+!     |
+!  #return 1
+
+: find-final-if ( node -- #if/f )
+    dup [
+        dup #if? [
+            dup node-successor #tail? [
+                node-successor find-final-if
+            ] unless
+        ] [
+            node-successor find-final-if
+        ] if
+    ] when ;
+
 : lift-loop-tail? ( #label -- tail/f )
-    dup node-child dup #if? [
+    dup node-successor node-successor [
-        node-children
+        dup node-param swap node-child find-final-if dup [
-        [ penultimate-node ] map
+            node-children [ penultimate-node ] map
-        [
+            [
-            dup #call-label?
+                dup #call-label?
-            [ node-param eq? not ] [ 2drop t ] if
+                [ node-param eq? not ] [ 2drop t ] if
-        ] with subset only-one
+            ] with subset only-one
-    ] [
+        ] [ 2drop f ] if
-        2drop f
+    ] [ drop f ] if ;
-    ] if ;
 
 ! M: #loop optimize-node*
 !     dup lift-loop-tail? dup [
-!         over node-child swap lift-branch t
+!         last-node >r
+!         dup detach-node-successor
+!         over node-child find-final-if detach-node-successor
+!         [ set-node-successor ] keep
+!         r> set-node-successor
+!         t
 !     ] [
 !         2drop t f
 !     ] if ;

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

@@ -118,3 +118,15 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
 : sole-consumer ( #call -- node/f )
     node-out-d first used-by
     dup length 1 = [ first ] [ drop f ] if ;
+
+: splice-def-use ( node -- )
+    #! As a first approximation, we take all the values used
+    #! by the set of new nodes, and push a 't' on their
+    #! def-use list here. We could perform a full graph
+    #! substitution, but we don't need to, because the next
+    #! optimizer iteration will do that. We just need a minimal
+    #! degree of accuracy; the new values should be marked as
+    #! having _some_ usage, so that flushing doesn't erronously
+    #! flush them away.
+    [ compute-def-use def-use get keys ] with-scope
+    def-use get [ [ t swap ?push ] change-at ] curry each ;

core/optimizer/optimizer.factor

@@ -12,7 +12,7 @@ IN: optimizer
         H{ } clone value-substitutions set
         dup compute-def-use
         kill-values
-        ! dup detect-loops
+        dup detect-loops
         dup infer-classes
         optimizer-changed off
         optimize-nodes