Merge branch 'master' of git://factorcode.org/git/factor

basis/compiler/cfg/branch-folding/branch-folding-tests.factor

@@ -1,89 +0,0 @@
-IN: compiler.cfg.branch-folding.tests
-USING: compiler.cfg.branch-folding compiler.cfg.instructions
-compiler.cfg compiler.cfg.registers compiler.cfg.debugger
-arrays compiler.cfg.phi-elimination compiler.cfg.dce
-compiler.cfg.predecessors compiler.cfg.comparisons
-kernel accessors assocs sequences classes namespaces
-tools.test cpu.architecture ;
-
-V{ T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
-} 1 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 1 1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 2 2 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##phi f V int-regs 3 { } }
-    T{ ##replace f V int-regs 3 D 0 }
-    T{ ##return }
-} 4 test-bb
-
-4 get instructions>> first
-2 get V int-regs 1 2array
-3 get V int-regs 2 2array 2array
->>inputs drop
-
-test-diamond
-
-[ ] [ cfg new 0 get >>entry fold-branches compute-predecessors eliminate-phis drop ] unit-test
-
-[ 1 ] [ 1 get successors>> length ] unit-test
-[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
-
-[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
-[ 3 get successors>> first instructions>> first ]
-unit-test
-
-[ 2 ] [ 4 get instructions>> length ] unit-test
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 1 }
-    T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
-} 1 test-bb
-
-V{
-    T{ ##copy f V int-regs 2 V int-regs 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##phi f V int-regs 3 V{ } }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace f V int-regs 3 D 0 }
-    T{ ##return }
-} 4 test-bb
-
-1 get V int-regs 1 2array
-2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
-
-test-diamond
-
-[ ] [
-    cfg new 0 get >>entry
-    compute-predecessors
-    fold-branches
-    compute-predecessors
-    eliminate-dead-code
-    drop
-] unit-test
-
-[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test

basis/compiler/cfg/branch-folding/branch-folding.factor

@@ -1,33 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit kernel sequences vectors
-compiler.cfg.instructions
-compiler.cfg.comparisons
-compiler.cfg.rpo
-compiler.cfg ;
-IN: compiler.cfg.branch-folding
-
-! Fold comparisons where both inputs are the same. Predecessors must be
-! recomputed after this
-
-: fold-branch? ( bb -- ? )
-    instructions>> last {
-        [ ##compare-branch? ]
-        [ [ src1>> ] [ src2>> ] bi = ]
-    } 1&& ;
-
-: chosen-successor ( bb -- succ )
-    [ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
-    [ successors>> ]
-    bi nth ;
-
-: fold-branch ( bb -- )
-    dup chosen-successor 1vector >>successors
-    instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
-
-: fold-branches ( cfg -- cfg' )
-    dup [
-        dup fold-branch?
-        [ fold-branch ] [ drop ] if
-    ] each-basic-block
-    cfg-changed ;

basis/compiler/cfg/branch-splitting/branch-splitting.factor

@@ -65,15 +65,15 @@ UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
 : split-instructions? ( insns -- ? )
     [ irrelevant? not ] count 5 <= ;
 
-: split-branches? ( bb -- ? )
+: split-branch? ( bb -- ? )
     {
         [ dup successors>> [ back-edge? ] with any? not ]
-        [ predecessors>> length 1 4 between? ]
+        [ predecessors>> length 2 4 between? ]
         [ instructions>> split-instructions? ]
     } 1&& ;
 
 : split-branches ( cfg -- cfg' )
     dup [
-        dup split-branches? [ split-branch ] [ drop ] if
+        dup split-branch? [ split-branch ] [ drop ] if
     ] each-basic-block
     cfg-changed ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences accessors layouts kernel math namespaces
-combinators fry locals
+combinators fry
 compiler.tree.propagation.info
 compiler.cfg.hats
 compiler.cfg.stacks
@@ -21,32 +21,8 @@ IN: compiler.cfg.intrinsics.fixnum
 : tag-literal ( n -- tagged )
     literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
 
-: emit-fixnum-imm-op1 ( infos insn -- dst )
+: emit-fixnum-op ( insn -- dst )
-    [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
+    [ 2inputs ] dip call ds-push ; inline
-
-: emit-fixnum-imm-op2 ( infos insn -- dst )
-    [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
-
-: (emit-fixnum-op) ( insn -- dst )
-    [ 2inputs ] dip call ; inline
-
-:: emit-fixnum-op ( node insn imm-insn -- )
-    [let | infos [ node node-input-infos ] |
-        infos second value-info-small-tagged?
-        [ infos imm-insn emit-fixnum-imm-op2 ]
-        [ insn (emit-fixnum-op) ] if
-        ds-push
-    ] ; inline
-
-:: emit-commutative-fixnum-op ( node insn imm-insn -- )
-    [let | infos [ node node-input-infos ] |
-        {
-            { [ infos first value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op1 ] }
-            { [ infos second value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op2 ] }
-            [ insn (emit-fixnum-op) ]
-        } cond
-        ds-push
-    ] ; inline
 
 : emit-fixnum-shift-fast ( node -- )
     dup node-input-infos dup second value-info-small-fixnum? [
@@ -66,34 +42,11 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-log2 ( -- )
     ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
 
-: (emit-fixnum*fast) ( -- dst )
+: emit-fixnum*fast ( -- )
-    2inputs ^^untag-fixnum ^^mul ;
+    2inputs ^^untag-fixnum ^^mul ds-push ;
 
-: (emit-fixnum*fast-imm1) ( infos -- dst )
+: emit-fixnum-comparison ( cc -- )
-    [ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ;
+    '[ _ ^^compare ] emit-fixnum-op ;
-
-: (emit-fixnum*fast-imm2) ( infos -- dst )
-    [ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
-
-: emit-fixnum*fast ( node -- )
-    node-input-infos
-    dup first value-info-small-fixnum? drop f
-    [
-        (emit-fixnum*fast-imm1)
-    ] [
-        dup second value-info-small-fixnum?
-        [ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if
-    ] if
-    ds-push ;
-
-: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
-    [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
-
-: emit-eq ( node -- )
-    cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
-
-: emit-fixnum-comparison ( node cc -- )
-    (emit-fixnum-comparison) emit-fixnum-op ;
 
 : emit-bignum>fixnum ( -- )
     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -103,20 +103,20 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
+        { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
-        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
+        { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
+        { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
+        { \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
         { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
-        { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+        { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
-        { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+        { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
-        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+        { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
-        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+        { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
-        { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+        { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
-        { \ kernel:eq? [ emit-eq ] }
+        { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
         { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
         { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
         { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }

basis/compiler/cfg/local/local.factor

@@ -1,10 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
+USING: locals accessors kernel assocs namespaces
+compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ;
 IN: compiler.cfg.local
 
-: optimize-basic-block ( bb init-quot insn-quot -- )
+:: optimize-basic-block ( bb init-quot insn-quot -- )
-    [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
+    bb basic-block set
+    bb live-in keys init-quot call
+    bb insn-quot change-instructions drop ; inline
 
-: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
+:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
-    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
+    cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block
+    cfg ; inline

basis/compiler/cfg/optimizer/optimizer.factor

@@ -9,7 +9,6 @@ compiler.cfg.branch-splitting
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
 compiler.cfg.dce
-compiler.cfg.branch-folding
 compiler.cfg.write-barrier
 compiler.cfg.liveness
 compiler.cfg.rpo
@@ -36,7 +35,6 @@ SYMBOL: check-optimizer?
         compute-liveness
         alias-analysis
         value-numbering
-        fold-branches
         compute-predecessors
         eliminate-dead-code
         eliminate-write-barriers

basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor

@@ -91,9 +91,9 @@ IN: compiler.cfg.stack-analysis.tests
 ! Sync before a back-edge, not after
 ! ##peeks should be inserted before a ##loop-entry
 ! Don't optimize out the constants
-[ 1 t ] [
+[ t ] [
     [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
-    [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
+    [ ##load-immediate? ] any?
 ] unit-test
 
 ! Correct height tracking

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes kernel math namespaces combinators
-compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
+combinators.short-circuit compiler.cfg.instructions
+compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.expressions
 
 ! Referentially-transparent expressions
@@ -11,15 +12,29 @@ TUPLE: binary-expr < expr in1 in2 ;
 TUPLE: commutative-expr < binary-expr ;
 TUPLE: compare-expr < binary-expr cc ;
 TUPLE: constant-expr < expr value ;
+TUPLE: reference-expr < expr value ;
 
 : <constant> ( constant -- expr )
     f swap constant-expr boa ; inline
 
 M: constant-expr equal?
     over constant-expr? [
-        [ [ value>> ] bi@ = ]
+        {
-        [ [ value>> class ] bi@ = ] 2bi
+            [ [ value>> class ] bi@ = ]
-        and
+            [ [ value>> ] bi@ = ]
+        } 2&&
+    ] [ 2drop f ] if ;
+
+: <reference> ( constant -- expr )
+    f swap reference-expr boa ; inline
+
+M: reference-expr equal?
+    over reference-expr? [
+        [ value>> ] bi@ {
+            { [ 2dup eq? ] [ 2drop t ] }
+            { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
+            [ 2drop f ]
+        } cond
     ] [ 2drop f ] if ;
 
 ! Expressions whose values are inputs to the basic block. We
@@ -39,6 +54,8 @@ GENERIC: >expr ( insn -- expr )
 
 M: ##load-immediate >expr val>> <constant> ;
 
+M: ##load-reference >expr obj>> <reference> ;
+
 M: ##unary >expr
     [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
 

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors locals combinators combinators.short-circuit arrays
+USING: accessors combinators combinators.short-circuit arrays
 fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise classes
+math.bitwise math.order classes vectors
+compiler.cfg
 compiler.cfg.hats
 compiler.cfg.comparisons
 compiler.cfg.instructions
@@ -11,6 +12,12 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.simplify ;
 IN: compiler.cfg.value-numbering.rewrite
 
+: vreg-small-constant? ( vreg -- ? )
+    vreg>expr {
+        [ constant-expr? ]
+        [ value>> small-enough? ]
+    } 1&& ;
+
 ! Outputs f to mean no change
 
 GENERIC: rewrite* ( insn -- insn/f )
@@ -76,48 +83,6 @@ M: ##compare-imm rewrite-tagged-comparison
     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
     i \ ##compare-imm new-insn ;
 
-M: ##compare-imm-branch rewrite*
-    {
-        { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
-        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
-        [ drop f ]
-    } cond ;
-
-:: >compare-imm ( insn swap? -- insn' )
-    insn dst>>
-    insn src1>>
-    insn src2>> swap? [ swap ] when vreg>constant
-    insn cc>> swap? [ swap-cc ] when
-    i \ ##compare-imm new-insn ; inline
-
-: vreg-small-constant? ( vreg -- ? )
-    vreg>expr {
-        [ constant-expr? ]
-        [ value>> small-enough? ]
-    } 1&& ;
-
-M: ##compare rewrite*
-    dup [ src1>> ] [ src2>> ] bi
-    [ vreg-small-constant? ] bi@ 2array {
-        { { f t } [ f >compare-imm ] }
-        { { t f } [ t >compare-imm ] }
-        [ 2drop f ]
-    } case ;
-
-:: >compare-imm-branch ( insn swap? -- insn' )
-    insn src1>>
-    insn src2>> swap? [ swap ] when vreg>constant
-    insn cc>> swap? [ swap-cc ] when
-    \ ##compare-imm-branch new-insn ; inline
-
-M: ##compare-branch rewrite*
-    dup [ src1>> ] [ src2>> ] bi
-    [ vreg-small-constant? ] bi@ 2array {
-        { { f t } [ f >compare-imm-branch ] }
-        { { t f } [ t >compare-imm-branch ] }
-        [ 2drop f ]
-    } case ;
-
 : rewrite-redundant-comparison? ( insn -- ? )
     {
         [ src1>> vreg>expr compare-expr? ]
@@ -133,10 +98,109 @@ M: ##compare-branch rewrite*
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
+ERROR: bad-comparison ;
+
+: (fold-compare-imm) ( insn -- ? )
+    [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
+    pick integer?
+    [ [ <=> ] dip evaluate-cc ]
+    [
+        2nip {
+            { cc= [ f ] }
+            { cc/= [ t ] }
+            [ bad-comparison ]
+        } case
+    ] if ;
+
+: fold-compare-imm? ( insn -- ? )
+    src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
+
+: fold-branch ( ? -- insn )
+    0 1 ?
+    basic-block get [ nth 1vector ] change-successors drop
+    \ ##branch new-insn ;
+
+: fold-compare-imm-branch ( insn -- insn/f )
+    (fold-compare-imm) fold-branch ;
+
+M: ##compare-imm-branch rewrite*
+    {
+        { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
+        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+        { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
+        [ drop f ]
+    } cond ;
+
+: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
+    [ [ swap ] dip swap-cc ] when ; inline
+
+: >compare-imm-branch ( insn swap? -- insn' )
+    [
+        [ src1>> ]
+        [ src2>> ]
+        [ cc>> ]
+        tri
+    ] dip
+    swap-compare
+    [ vreg>constant ] dip
+    \ ##compare-imm-branch new-insn ; inline
+
+: self-compare? ( insn -- ? )
+    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
+
+: (rewrite-self-compare) ( insn -- ? )
+    cc>> { cc= cc<= cc>= } memq? ;
+
+: rewrite-self-compare-branch ( insn -- insn' )
+    (rewrite-self-compare) fold-branch ;
+
+M: ##compare-branch rewrite*
+    {
+        { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
+        { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
+        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
+        [ drop f ]
+    } cond ;
+
+: >compare-imm ( insn swap? -- insn' )
+    [
+        {
+            [ dst>> ]
+            [ src1>> ]
+            [ src2>> ]
+            [ cc>> ]
+        } cleave
+    ] dip
+    swap-compare
+    [ vreg>constant ] dip
+    i \ ##compare-imm new-insn ; inline
+
+: >boolean-insn ( insn ? -- insn' )
+    [ dst>> ] dip
+    {
+        { t [ t \ ##load-reference new-insn ] }
+        { f [ \ f tag-number \ ##load-immediate new-insn ] }
+    } case ;
+
+: rewrite-self-compare ( insn -- insn' )
+    dup (rewrite-self-compare) >boolean-insn ;
+
+M: ##compare rewrite*
+    {
+        { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
+        { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
+        { [ dup self-compare? ] [ rewrite-self-compare ] }
+        [ drop f ]
+    } cond ;
+
+: fold-compare-imm ( insn -- insn' )
+    dup (fold-compare-imm) >boolean-insn ;
+
 M: ##compare-imm rewrite*
     {
         { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+        { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
         [ drop f ]
     } cond ;
 
@@ -160,22 +224,19 @@ M: ##shl-imm constant-fold* drop shift ;
     [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
     \ ##load-immediate new-insn ; inline
 
-:: new-imm-insn ( insn dst src1 src2 op -- new-insn/insn )
-    src2 small-enough? [ dst src1 src2 op new-insn ] [ insn ] if ; inline
-
 : reassociate? ( insn -- ? )
     [ src1>> vreg>expr op>> ] [ class ] bi = ; inline
 
 : reassociate ( insn op -- insn )
     [
         {
-            [ ]
             [ dst>> ]
             [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
             [ src2>> ]
             [ ]
         } cleave constant-fold*
-    ] dip new-imm-insn ; inline
+    ] dip
+    over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
 
 M: ##add-imm rewrite*
     {
@@ -185,8 +246,8 @@ M: ##add-imm rewrite*
     } cond ;
 
 : sub-imm>add-imm ( insn -- insn' )
-    dup [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
+    [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
-    [ \ ##add-imm new-insn nip ] [ 2drop 2drop f ] if ;
+    [ \ ##add-imm new-insn ] [ 3drop f ] if ;
 
 M: ##sub-imm rewrite*
     {
@@ -247,12 +308,11 @@ M: ##sar-imm rewrite*
         [ drop f ]
     } cond ;
 
-:: insn>imm-insn ( insn op swap? -- )
+: insn>imm-insn ( insn op swap? -- )
-    insn
+    swap [
-    insn dst>>
+        [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
-    insn src1>>
+        [ swap ] when vreg>constant
-    insn src2>> swap? [ swap ] when vreg>constant
+    ] dip new-insn ; inline
-    op new-imm-insn ; inline
 
 : rewrite-arithmetic ( insn op -- ? )
     {

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -2,7 +2,9 @@ IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
 cpu.architecture tools.test kernel math combinators.short-circuit
-accessors sequences compiler.cfg vectors arrays layouts ;
+accessors sequences compiler.cfg.predecessors
+compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg.liveness
+compiler.cfg assocs vectors arrays layouts namespaces ;
 
 : trim-temps ( insns -- insns )
     [
@@ -17,6 +19,55 @@ accessors sequences compiler.cfg vectors arrays layouts ;
     { } init-value-numbering
     value-numbering-step ;
 
+! Folding constants together
+[
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 -0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    }
+] [
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 -0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 0 D 1 }
+    }
+] [
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-reference f V int-regs 0 t }
+        T{ ##load-reference f V int-regs 1 t }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 0 D 1 }
+    }
+] [
+    {
+        T{ ##load-reference f V int-regs 0 t }
+        T{ ##load-reference f V int-regs 1 t }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    } test-value-numbering
+] unit-test
+
 ! Copy propagation
 [
     {
@@ -805,4 +856,479 @@ cell 8 = [
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
         } test-value-numbering
     ] unit-test
-] when
+
+    [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 140737488355328 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        }
+    ] [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 140737488355328 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        } test-value-numbering
+    ] unit-test
+
+    [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 2147483647 }
+            T{ ##add-imm f V int-regs 3 V int-regs 0 2147483647 }
+            T{ ##add-imm f V int-regs 4 V int-regs 3 2147483647 }
+        }
+    ] [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 2147483647 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+            T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+        } test-value-numbering
+    ] unit-test
+] when
+
+! Branch folding
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-immediate f V int-regs 3 5 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-reference f V int-regs 3 t }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-reference f V int-regs 3 t }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-immediate f V int-regs 3 5 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 5 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 5 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 5 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
+    } test-value-numbering
+] unit-test
+
+: test-branch-folding ( insns -- insns' n )
+    <basic-block>
+    [ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep
+    successors>> first ;
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 1 V int-regs 2 cc= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 1 V int-regs 2 cc/= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 1 V int-regs 2 cc< }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 2 V int-regs 1 cc< }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc<= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc> }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc>= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc/= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+        T{ ##compare-imm-branch f V int-regs 1 5 cc/= }
+    } test-branch-folding
+] unit-test
+
+! More branch folding tests
+V{ T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+    T{ ##load-immediate f V int-regs 1 1 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##load-immediate f V int-regs 2 2 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f V int-regs 3 { } }
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-liveness
+    value-numbering
+    compute-predecessors
+    eliminate-phis drop
+] unit-test
+
+[ 1 ] [ 1 get successors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
+[ 3 get successors>> first instructions>> first ]
+unit-test
+
+[ 2 ] [ 4 get instructions>> length ] unit-test
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+} 1 test-bb
+
+V{
+    T{ ##copy f V int-regs 2 V int-regs 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f V int-regs 3 V{ } }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+1 get V int-regs 1 2array
+2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+
+test-diamond
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-predecessors
+    compute-liveness
+    value-numbering
+    compute-predecessors
+    eliminate-dead-code
+    drop
+] unit-test
+
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
+
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek { dst V int-regs 15 } { loc D 0 } }
+    T{ ##copy { dst V int-regs 16 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 17 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 18 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 19 } { src V int-regs 15 } }
+    T{ ##compare
+        { dst V int-regs 20 }
+        { src1 V int-regs 18 }
+        { src2 V int-regs 19 }
+        { cc cc= }
+        { temp V int-regs 22 }
+    }
+    T{ ##copy { dst V int-regs 21 } { src V int-regs 20 } }
+    T{ ##compare-imm-branch
+        { src1 V int-regs 21 }
+        { src2 5 }
+        { cc cc/= }
+    }
+} 1 test-bb
+
+V{
+    T{ ##copy { dst V int-regs 23 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 24 } { src V int-regs 15 } }
+    T{ ##load-reference { dst V int-regs 25 } { obj t } }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace { src V int-regs 25 } { loc D 0 } }
+    T{ ##epilogue }
+    T{ ##return }
+} 3 test-bb
+
+V{
+    T{ ##copy { dst V int-regs 26 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 27 } { src V int-regs 15 } }
+    T{ ##add
+        { dst V int-regs 28 }
+        { src1 V int-regs 26 }
+        { src2 V int-regs 27 }
+    }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##replace { src V int-regs 28 } { loc D 0 } }
+    T{ ##epilogue }
+    T{ ##return }
+} 5 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 4 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-liveness value-numbering eliminate-dead-code drop
+] unit-test
+
+[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test

basis/compiler/cfg/value-numbering/value-numbering.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
 sorting sets sequences fry
+compiler.cfg
 compiler.cfg.local
 compiler.cfg.liveness
 compiler.cfg.renaming
@@ -11,6 +12,8 @@ compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
+! Local value numbering. Predecessors must be recomputed after this
+
 : number-input-values ( live-in -- )
     [ [ f next-input-expr simplify ] dip set-vn ] each ;
 
@@ -32,4 +35,5 @@ IN: compiler.cfg.value-numbering
     [ rewrite ] map dup rename-uses ;
 
 : value-numbering ( cfg -- cfg' )
-    [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
+    [ init-value-numbering ] [ value-numbering-step ] local-optimization
+    cfg-changed ;

basis/compiler/tests/codegen.factor

@@ -318,4 +318,7 @@ M: cucumber equal? "The cucumber has no equal" throw ;
 
 cell 4 = [
     [ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
-] when
+] when
+
+! Regression from Slava's value numbering changes
+[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test