Merge branch 'master' into inlinec

* master:
  rewrite rules for add/sub/mul/and/or/xor-imm, rewrite load-immediate/add to be add-imm
  simplify sub and sub-imm
  add a utility word vreg>constant
  compiler.cfg.dce: now performs three passes over the CFG to fix a phase ordering issue
  compiler.cfg.dce: minor renamings
  Dead code elimination eliminates some dead allocations
  compiler.cfg.optimizer: enable branch folding
  compiler.cfg: bug fixes in GC check insertion and fixnum intrinsics
  compiler.cfg.linear-scan: fix spilling

basis/compiler/cfg/dce/authors.txt

@@ -1 +1,2 @@
-Slava Pestov
+Slava Pestov
+Daniel Ehrenberg

basis/compiler/cfg/dce/dce-tests.factor

@@ -0,0 +1,72 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test compiler.cfg kernel accessors compiler.cfg.dce
+compiler.cfg.instructions compiler.cfg.registers cpu.architecture ;
+IN: compiler.cfg.dce.tests
+
+: test-dce ( insns -- insns' )
+    <basic-block> swap >>instructions
+    cfg new swap >>entry
+    eliminate-dead-code
+    entry>> instructions>> ; 
+
+[ V{
+    T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+    T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+    T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+    T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} ] [ V{
+    T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+    T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+    T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+    T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+    T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+    T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+    T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test
+
+[ V{
+    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} ] [ V{
+    T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+    T{ ##replace { src V int-regs 1 } { loc D 0 } }
+    T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+    T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test

basis/compiler/cfg/dce/dce.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sets kernel namespaces sequences
 compiler.cfg.instructions compiler.cfg.def-use
@@ -11,35 +11,93 @@ SYMBOL: liveness-graph
 ! vregs which participate in side effects and thus are always live
 SYMBOL: live-vregs
 
+: live-vreg? ( vreg -- ? )
+    live-vregs get key? ;
+
+! vregs which are the result of an allocation
+SYMBOL: allocations
+
+: allocation? ( vreg -- ? )
+    allocations get key? ;
+
 : init-dead-code ( -- )
     H{ } clone liveness-graph set
-    H{ } clone live-vregs set ;
+    H{ } clone live-vregs set
+    H{ } clone allocations set ;
 
-GENERIC: update-liveness-graph ( insn -- )
+GENERIC: build-liveness-graph ( insn -- )
 
-M: ##flushable update-liveness-graph
-    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+: add-edges ( insn register -- )
+    [ uses-vregs ] dip liveness-graph get [ union ] change-at ;
 
-: record-live ( vregs -- )
+: setter-liveness-graph ( insn vreg -- )
+    dup allocation? [ add-edges ] [ 2drop ] if ;
+
+M: ##set-slot build-liveness-graph
+    dup obj>> setter-liveness-graph ;
+
+M: ##set-slot-imm build-liveness-graph
+    dup obj>> setter-liveness-graph ;
+
+M: ##write-barrier build-liveness-graph
+    dup src>> setter-liveness-graph ;
+
+M: ##flushable build-liveness-graph
+    dup dst>> add-edges ;
+
+M: ##allot build-liveness-graph
+    [ dst>> allocations get conjoin ]
+    [ call-next-method ] bi ;
+
+M: insn build-liveness-graph drop ;
+
+GENERIC: compute-live-vregs ( insn -- )
+
+: (record-live) ( vregs -- )
     [
         dup live-vregs get key? [ drop ] [
             [ live-vregs get conjoin ]
-            [ liveness-graph get at record-live ]
+            [ liveness-graph get at (record-live) ]
             bi
         ] if
     ] each ;
 
-M: insn update-liveness-graph uses-vregs record-live ;
+: record-live ( insn -- )
+    uses-vregs (record-live) ;
+
+: setter-live-vregs ( insn vreg -- )
+    allocation? [ drop ] [ record-live ] if ;
+
+M: ##set-slot compute-live-vregs
+    dup obj>> setter-live-vregs ;
+
+M: ##set-slot-imm compute-live-vregs
+    dup obj>> setter-live-vregs ;
+
+M: ##write-barrier compute-live-vregs
+    dup src>> setter-live-vregs ;
+
+M: ##flushable compute-live-vregs drop ;
+
+M: insn compute-live-vregs
+    record-live ;
 
 GENERIC: live-insn? ( insn -- ? )
 
-M: ##flushable live-insn? dst>> live-vregs get key? ;
+M: ##flushable live-insn? dst>> live-vreg? ;
+
+M: ##set-slot live-insn? obj>> live-vreg? ;
+
+M: ##set-slot-imm live-insn? obj>> live-vreg? ;
+
+M: ##write-barrier live-insn? src>> live-vreg? ;
 
 M: insn live-insn? drop t ;
 
 : eliminate-dead-code ( cfg -- cfg' )
     init-dead-code
-    [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
+    dup
+    [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
+    [ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
     [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
-    [ ]
-    tri ;
+    tri ;

basis/compiler/cfg/dce/summary.txt

@@ -0,0 +1 @@
+Dead code elimination

basis/compiler/cfg/instructions/instructions.factor

@@ -240,7 +240,7 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
 
 INSN: _compare-float-branch < _conditional-branch ;
 
-TUPLE: spill-slot n ; C: <spill-slot> spill-slot
+TUPLE: spill-slot { n integer } ; C: <spill-slot> spill-slot
 
 INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
 

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

@@ -39,38 +39,25 @@ IN: compiler.cfg.intrinsics.fixnum
 
 :: 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)
-            ] if
-        ] if
+        {
+            { [ 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) ( obj node -- obj )
-    literal>> dup sgn {
-        { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
-        {  0 [ drop ] }
-        {  1 [ ^^shl-imm ] }
-    } case ;
-
 : emit-fixnum-shift-fast ( node -- )
-    dup node-input-infos dup first value-info-small-fixnum? [
+    dup node-input-infos dup second value-info-small-fixnum? [
         nip
-        [ ds-pop ds-drop ] dip first (emit-fixnum-shift-fast) ds-push
-    ] [
-        drop
-        dup node-input-infos dup second value-info-small-fixnum? [
-            nip
-            [ ds-drop ds-pop ] dip second (emit-fixnum-shift-fast) ds-push
-        ] [
-            drop emit-primitive
-        ] if
-    ] if ;
+        [ ds-drop ds-pop ] dip
+        second literal>> dup sgn {
+            { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
+            {  0 [ drop ] }
+            {  1 [ ^^shl-imm ] }
+        } case
+        ds-push
+    ] [ drop emit-primitive ] if ;
     
 : emit-fixnum-bitnot ( -- )
     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
@@ -89,7 +76,7 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : emit-fixnum*fast ( node -- )
     node-input-infos
-    dup first value-info-small-fixnum?
+    dup first value-info-small-fixnum? drop f
     [
         (emit-fixnum*fast-imm1)
     ] [

basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor

@@ -26,13 +26,13 @@ ERROR: bad-live-ranges interval ;
         [ drop ] [ bad-live-ranges ] if
     ] [ drop ] if ;
 
-: trim-before-ranges ( live-interval n -- )
+: trim-before-ranges ( live-interval -- )
     [ ranges>> ] [ uses>> last ] bi
     [ '[ from>> _ <= ] filter-here ]
     [ swap last (>>to) ]
     2bi ;
 
-: trim-after-ranges ( live-interval n -- )
+: trim-after-ranges ( live-interval -- )
     [ ranges>> ] [ uses>> first ] bi
     [ '[ to>> _ >= ] filter-here ]
     [ swap first (>>from) ]
@@ -56,7 +56,7 @@ ERROR: bad-live-ranges interval ;
     over spill-to>> >>reload-from ;
 
 : split-and-spill ( new existing -- before after )
-    swap start>> split-for-spill assign-spill assign-reload ;
+    swap start>> split-for-spill [ assign-spill ] dip assign-reload ;
 
 : reuse-register ( new existing -- )
     [ nip delete-active ]

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -136,8 +136,8 @@ M: vreg-insn assign-registers-in-insn
     register-mapping ;
 
 : compute-live-spill-slots ( -- spill-slots )
-    spill-slots get values [ values ] map concat
-    [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
+    spill-slots get values
+    [ [ vreg>> swap ] { } assoc-map-as ] map concat ;
 
 M: ##gc assign-registers-in-insn
     dup call-next-method

basis/compiler/cfg/optimizer/optimizer.factor

@@ -37,8 +37,8 @@ SYMBOL: check-optimizer?
         compute-liveness
         alias-analysis
         value-numbering
-        ! fold-branches
-        ! compute-predecessors
+        fold-branches
+        compute-predecessors
         eliminate-dead-code
         eliminate-write-barriers
         eliminate-phis

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

@@ -26,6 +26,8 @@ SYMBOL: vregs>vns
 
 : vn>constant ( vn -- constant ) vn>expr value>> ; inline
 
+: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline
+
 : init-value-graph ( -- )
     0 vn-counter set
     <bihash> exprs>vns set

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

@@ -5,16 +5,12 @@ compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.simplify fry kernel layouts math
-namespaces sequences ;
+namespaces sequences cpu.architecture math.bitwise locals ;
 IN: compiler.cfg.value-numbering.rewrite
 
 GENERIC: rewrite ( insn -- insn' )
 
-M: ##mul-imm rewrite
-    dup src2>> dup power-of-2? [
-        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
-        dup number-values
-    ] [ drop ] if ;
+M: insn rewrite ;
 
 : ##branch-t? ( insn -- ? )
     dup ##compare-imm-branch? [
@@ -80,7 +76,7 @@ M: ##compare-imm-branch rewrite
 : flip-comparison ( insn -- insn' )
     [ dst>> ]
     [ src2>> ]
-    [ src1>> vreg>vn vn>constant ] tri
+    [ src1>> vreg>constant ] tri
     cc= i \ ##compare-imm new-insn ;
 
 M: ##compare rewrite
@@ -117,20 +113,66 @@ M: ##compare-imm rewrite
         ] when
     ] when ;
 
-: combine-add-imm? ( insn -- ? )
-    {
-        [ src1>> vreg>expr op>> \ ##add-imm = ]
-        [ src2>> number? ]
-    } 1&& ;
+: combine-imm? ( insn op -- ? )
+    [ src1>> vreg>expr op>> ] dip = ;
 
-: combine-add-imm ( dst src n -- insn )
-    [ vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] dip
-    + \ ##add-imm new-insn ;
+:: combine-imm ( insn quot op -- insn )
+    insn
+    [ dst>> ]
+    [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
+    [ src2>> ] tri
+
+    quot call cell-bits bits
+
+    dup small-enough? [
+        op new-insn dup number-values
+    ] [
+        3drop insn
+    ] if ; inline
 
 M: ##add-imm rewrite
-    dup combine-add-imm? [
-        [ dst>> ] [ src1>> ] [ src2>> ] tri combine-add-imm
+    {
+        { [ dup \ ##add-imm combine-imm? ]
+            [ [ + ] \ ##add-imm combine-imm ] }
+        { [ dup \ ##sub-imm combine-imm? ]
+            [ [ - ] \ ##sub-imm combine-imm ] }
+        [ ]
+    } cond ;
+
+M: ##sub-imm rewrite
+    {
+        { [ dup \ ##add-imm combine-imm? ]
+            [ [ - ] \ ##add-imm combine-imm ] }
+        { [ dup \ ##sub-imm combine-imm? ]
+            [ [ + ] \ ##sub-imm combine-imm ] }
+        [ ]
+    } cond ;
+
+M: ##mul-imm rewrite
+    dup src2>> dup power-of-2? [
+        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
+        dup number-values
+    ] [
+        drop dup \ ##mul-imm combine-imm?
+        [ [ * ] \ ##mul-imm combine-imm ] when
+    ] if ;
+
+M: ##and-imm rewrite
+    dup \ ##and-imm combine-imm?
+    [ [ bitand ] \ ##and-imm combine-imm ] when ;
+
+M: ##or-imm rewrite
+    dup \ ##or-imm combine-imm?
+    [ [ bitor ] \ ##or-imm combine-imm ] when ;
+
+M: ##xor-imm rewrite
+    dup \ ##xor-imm combine-imm?
+    [ [ bitxor ] \ ##xor-imm combine-imm ] when ;
+
+M: ##add rewrite
+    dup src2>> vreg>expr constant-expr? [
+        [ dst>> ]
+        [ src1>> ]
+        [ src2>> vreg>constant ] tri \ ##add-imm new-insn
         dup number-values
     ] when ;
-
-M: insn rewrite ;

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

@@ -3,7 +3,7 @@
 USING: kernel accessors combinators classes math layouts
 compiler.cfg.instructions
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.expressions locals ;
 IN: compiler.cfg.value-numbering.simplify
 
 ! Return value of f means we didn't simplify.
@@ -42,6 +42,13 @@ M: unary-expr simplify*
         [ 2drop f ]
     } cond ; inline
 
+: simplify-sub ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] }
+        { [ dup expr-zero? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
 : useless-shift? ( in1 in2 -- ? )
     over op>> \ ##shl-imm eq?
     [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
@@ -54,6 +61,8 @@ M: binary-expr simplify*
     dup op>> {
         { \ ##add [ simplify-add ] }
         { \ ##add-imm [ simplify-add ] }
+        { \ ##sub [ simplify-sub ] }
+        { \ ##sub-imm [ simplify-sub ] }
         { \ ##shr-imm [ simplify-shift ] }
         { \ ##sar-imm [ simplify-shift ] }
         [ 2drop f ]

basis/stuff.factor

@@ -0,0 +1,20 @@
+
+: spill-integer-base ( -- n )
+    stack-frame get spill-counts>> double-float-regs swap at
+    double-float-regs reg-size * ;
+
+: spill-integer@ ( n -- offset )
+    cells spill-integer-base + param@ ;
+
+: spill-float@ ( n -- offset )
+    double-float-regs reg-size * param@ ;
+
+: (stack-frame-size) ( stack-frame -- n )
+    [
+        {
+            [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+            [ gc-roots>> cells ]
+            [ params>> ]
+            [ return>> ]
+        } cleave
+    ] sum-outputs ;