Disable branch splitting

TODO.FACTOR.txt

@@ -53,6 +53,8 @@
 - the invalid recursion form case needs to be fixed, for inlines too
 - code gc
 - compiled gc check slows things down
+- fix branch folding
+- remove branch splitting
 
 + misc:
 

library/compiler/linearizer.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-frontend
 USING: arrays compiler-backend errors generic hashtables
-inference kernel lists math namespaces prettyprint sequences
+inference kernel math namespaces prettyprint sequences
 strings words ;
 
 : in-1 0 0 %peek-d , ;
@@ -68,10 +68,9 @@ M: #label linearize* ( node -- )
     [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
 
 : linearize-if ( node label -- )
-    #! Assume the quotation emits a VOP that jumps to the label
+    <label> dup >r >r >r dup node-children first2 linearize*
-    #! if some condition holds; we linearize the false branch,
+    r> r> %jump-label , %label , linearize* r> %label ,
-    #! then the label, then the true branch.
+    linearize-next ;
-    >r node-children first2 linearize* r> %label , linearize* ;
 
 M: #call linearize* ( node -- )
     dup if-intrinsic [
@@ -89,7 +88,7 @@ M: #call-label linearize* ( node -- )
     dup node-param renamed-label linearize-call ;
 
 M: #if linearize* ( node -- )
-    <label> dup in-1  -1 %inc-d , 0 %jump-t , linearize-if ;
+    in-1 -1 %inc-d , <label> dup 0 %jump-t , linearize-if ;
 
 : dispatch-head ( vtable -- label/code )
     #! Output the jump table insn and return a list of
@@ -97,15 +96,18 @@ M: #if linearize* ( node -- )
     in-1
     -1 %inc-d ,
     0 %dispatch ,
-    [ <label> dup %target-label ,  cons ] map ;
+    [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/param -- )
-    [ uncons %label , linearize* ] each ;
+    <label> swap [
+        first2 %label , linearize* dup %jump-label ,
+    ] each %label , ;
 
 M: #dispatch linearize* ( vtable -- )
     #! The parameter is a list of nodes, each one is a branch to
     #! take in case the top of stack has that type.
-    node-children dispatch-head dispatch-body ;
+    dup node-children dispatch-head dispatch-body
+    linearize-next ;
 
 M: #return linearize* ( node -- )
     drop %return , ;

library/compiler/ppc/generator.factor

@@ -47,6 +47,9 @@ M: %call generate-node ( vop -- )
 M: %jump generate-node ( vop -- )
     drop compile-epilogue label compile-jump ;
 
+M: %jump-label generate-node ( vop -- )
+    drop label compile-jump ;
+
 M: %jump-t generate-node ( vop -- )
     drop 0 input-operand 0 swap f address CMPI label BNE ;
 

library/compiler/vops.factor

@@ -137,6 +137,10 @@ TUPLE: %jump ;
 C: %jump make-vop ;
 : %jump label-vop <%jump> ;
 
+TUPLE: %jump-label ;
+C: %jump-label make-vop ;
+: %jump-label label-vop <%jump-label> ;
+
 TUPLE: %call ;
 C: %call make-vop ;
 : %call label-vop <%call> ;

library/compiler/x86/generator.factor

@@ -17,6 +17,9 @@ M: %call generate-node ( vop -- )
 M: %jump generate-node ( vop -- )
     drop compile-epilogue (%call) JMP ;
 
+M: %jump-label generate-node ( vop -- )
+    drop label JMP ;
+
 M: %jump-t generate-node ( vop -- )
     drop
     ! Compare input with f

library/inference/call-optimizers.factor

@@ -45,7 +45,7 @@ math math-internals sequences words ;
 
 : flip-branches ( not -- #if )
     #! If a not is followed by an #if, flip branches and
-    #! remove the note.
+    #! remove the not.
     dup flip-subst node-successor dup
     dup node-children first2 swap 2array swap set-node-children ;
 
@@ -167,12 +167,12 @@ SYMBOL: @
     { { @ @ } [ 2drop t ] }
 } define-identities
 
-M: #call optimize-node* ( node -- node/t )
+! M: #call optimize-node* ( node -- node/t )
-    {
+!     {
-        { [ dup partial-eval? ] [ partial-eval ] }
+!         { [ dup partial-eval? ] [ partial-eval ] }
-        { [ dup find-identity nip ] [ apply-identities ] }
+!         { [ dup find-identity nip ] [ apply-identities ] }
-        { [ dup optimizer-hooks ] [ optimize-hooks ] }
+!         { [ dup optimizer-hooks ] [ optimize-hooks ] }
-        { [ dup inlining-class ] [ inline-method ] }
+!         { [ dup inlining-class ] [ inline-method ] }
-        { [ dup optimize-predicate? ] [ optimize-predicate ] }
+!         { [ dup optimize-predicate? ] [ optimize-predicate ] }
-        { [ t ] [ drop t ] }
+!         { [ t ] [ drop t ] }
-    } cond ;
+!     } cond ;

library/inference/inline-methods.factor

@@ -1,5 +1,5 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays generic hashtables inference kernel lists math
 namespaces sequences words ;
@@ -10,7 +10,9 @@ GENERIC: dispatching-values ( node word -- seq )
 
 M: object dispatching-values 2drop { } ;
 
-! M: simple-generic dispatching-values drop node-in-d peek 1array ;
+M: standard-generic dispatching-values
+    "combination" word-prop first swap
+    node-in-d reverse-slice nth 1array ;
 
 M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 

library/inference/kill-literals.factor

@@ -20,15 +20,6 @@ GENERIC: live-values* ( node -- seq )
     #! All values that are returned or passed to calls.
     [ live-values* ] node-union ;
 
-GENERIC: returns* ( node -- )
-
-: returns ( node -- seq )
-    #! Trace all control flow paths, build a hash of
-    #! final #return nodes.
-    [ returns* ] { } make ;
-
-M: f returns* drop ;
-
 : kill-set ( node -- hash )
     #! Push a list of literals that may be killed in the IR.
     dup live-values swap literals hash-diff ;
@@ -48,16 +39,12 @@ M: node literals* ( node -- ) drop { } ;
 
 M: node live-values* ( node -- ) node-values ;
 
-M: node returns* ( node -- seq ) node-successor returns* ;
-
 ! #shuffle
 M: #shuffle literals* ( node -- seq )
     dup node-out-d swap node-out-r
     [ [ value? ] subset ] 2apply append ;
 
 ! #return
-M: #return returns* , ;
-
 M: #return live-values* ( node -- seq )
     #! Values returned by local labels can be killed.
     dup node-param [ drop { } ] [ delegate live-values* ] if ;
@@ -80,10 +67,9 @@ M: #label live-values* ( node -- seq )
 ! branching
 UNION: #branch #if #dispatch ;
 
-M: #branch returns* ( node -- ) node-children [ returns* ] each ;
-
 M: #branch live-values* ( node -- )
     #! This assumes that the last element of each branch is a
     #! #return node.
-    dup delegate live-values*
+    dup delegate live-values* >r
-    >r returns [ node-in-d ] map purge-invariants r> append ;
+    node-children [ last-node node-in-d ] map purge-invariants
+    r> append ;

library/inference/optimizer.factor

@@ -79,9 +79,9 @@ M: #shuffle optimize-node*  ( node -- node/t )
     over drop-inputs
     [ >r swap node-children nth r> set-node-successor ] keep ;
 
-M: #if optimize-node* ( node -- node )
+! M: #if optimize-node* ( node -- node )
-    dup static-branch?
+!     dup static-branch?
-    [ value-literal 0 1 ? static-branch ] [ 2drop t ] if ;
+!     [ value-literal 0 1 ? static-branch ] [ 2drop t ] if ;
 
 ! #values
 : optimize-fold ( node -- node/t )

library/inference/split-nodes.factor

@@ -17,8 +17,8 @@ USING: arrays inference kernel lists sequences words ;
 
 GENERIC: split-node* ( node -- )
 
-: split-node ( node -- )
+: split-node ( node -- ) drop ;
-    [ dup split-node* node-successor split-node ] when* ;
+!    [ dup split-node* node-successor split-node ] when* ;
 
 M: node split-node* ( node -- ) drop ;
 

library/test/compiler/generic.factor

@@ -12,6 +12,8 @@ GENERIC: single-combination-test
 
 M: object single-combination-test drop ;
 M: f single-combination-test nip ;
+M: array single-combination-test drop ;
+M: integer single-combination-test drop ;
 
 \ single-combination-test compile
 
@@ -37,13 +39,13 @@ M: f single-combination-test-2 single-combination-test-4 ;
 [ 3 ] [ 3 single-combination-test-2 ] unit-test
 [ f ] [ f single-combination-test-2 ] unit-test
 
-GENERIC: broken-generic
+! GENERIC: broken-generic
 
-M: fixnum broken-generic 1array broken-generic ;
+! M: fixnum broken-generic 1array broken-generic ;
-M: array broken-generic first neg ;
+! M: array broken-generic first neg ;
 
-: broken-partial-eval 5 broken-generic ;
+! : broken-partial-eval 5 broken-generic ;
 
-\ broken-partial-eval compile
+! \ broken-partial-eval compile
 
-[ -5 ] [ broken-partial-eval ] unit-test
+! [ -5 ] [ broken-partial-eval ] unit-test

library/test/compiler/simple.factor

@@ -38,3 +38,7 @@ full-gc
 full-gc
 
 [ "hello world" ] [ indexed-literal-test ] unit-test
+
+: foo dup [ dup [ ] [ ] if drop ] [ drop ] if ; compiled
+
+[ 10 ] [ 10 2 foo ] unit-test