compiler.cfg.representations: fix various bugs

basis/compiler/cfg/representations/coalescing/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/representations/coalescing/coalescing-tests.factor

@@ -0,0 +1,43 @@
+USING: arrays sequences kernel namespaces accessors compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.debugger
+compiler.cfg.representations.coalescing
+tools.test ;
+IN: compiler.cfg.representations.coalescing.tests
+
+: test-scc ( -- )
+    cfg new 0 get >>entry compute-components ;
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 2 D 0 }
+    T{ ##load-integer f 0 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 1 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+1 get 0 2array
+2 get 1 2array 2array 3 get instructions>> first (>>inputs)
+
+[ ] [ test-scc ] unit-test
+
+[ t ] [ 0 vreg>scc 1 vreg>scc = ] unit-test
+[ t ] [ 0 vreg>scc 3 vreg>scc = ] unit-test
+[ f ] [ 2 vreg>scc 3 vreg>scc = ] unit-test

basis/compiler/cfg/representations/coalescing/coalescing.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.rpo disjoint-sets fry
+kernel namespaces sequences ;
+IN: compiler.cfg.representations.coalescing
+
+! Find all strongly connected components in the graph where the
+! edges are ##phi or ##copy vreg uses
+SYMBOL: components
+
+: init-components ( cfg components -- )
+    '[
+        instructions>> [
+            defs-vreg [ _ add-atom ] when*
+        ] each
+    ] each-basic-block ;
+
+GENERIC# visit-insn 1 ( insn disjoint-set -- )
+
+M: ##copy visit-insn
+    [ [ dst>> ] [ src>> ] bi ] dip equate ;
+
+M: ##phi visit-insn
+    [ [ inputs>> values ] [ dst>> ] bi ] dip equate-all-with ;
+
+M: insn visit-insn 2drop ;
+
+: merge-components ( cfg components -- )
+    '[
+        instructions>> [
+            _ visit-insn
+        ] each
+    ] each-basic-block ;
+
+: compute-components ( cfg -- )
+    <disjoint-set>
+    [ init-components ]
+    [ merge-components ]
+    [ components set drop ] 2tri ;
+
+: vreg>scc ( vreg -- scc )
+    components get representative ;

basis/compiler/cfg/representations/preferred/preferred.factor

@@ -80,7 +80,7 @@ PRIVATE>
 : each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
 
-: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
     '[
         [ basic-block set ] [
             [

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

@@ -3,7 +3,9 @@ compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.representations.preferred cpu.architecture kernel
 namespaces tools.test sequences arrays system literals layouts
 math compiler.constants compiler.cfg.representations.conversion
-compiler.cfg.representations.rewrite make ;
+compiler.cfg.representations.rewrite
+compiler.cfg.comparisons
+make ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -116,8 +118,51 @@ V{
     }
 ] [ 1 get instructions>> ] unit-test
 
-! But its ok to untag-fixnum the result of a peek if there are
+! We cannot untag-fixnum the result of a peek if there are usages
-! no usages of it as a tagged-rep
+! of it as a tagged-rep
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##replace f 1 R 0 }
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+V{
+    T{ ##mul f 2 1 1 }
+    T{ ##replace f 2 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
+
+! But its ok to untag-fixnum the result of a peek if all usages use
+! it as int-rep
 V{
     T{ ##prologue }
     T{ ##branch }
@@ -135,7 +180,9 @@ V{
 
 V{
     T{ ##add f 2 1 1 }
+    T{ ##mul f 3 1 1 }
     T{ ##replace f 2 D 0 }
+    T{ ##replace f 3 D 1 }
     T{ ##branch }
 } 3 test-bb
 
@@ -187,6 +234,93 @@ V{
 
 [ t ] [ 1 get instructions>> 4 swap nth ##scalar>integer? ] unit-test
 
+! Test phi node behavior
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-integer f 1 1 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 2 2 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 }
+    T{ ##replace f 3 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+1 get 1 2array
+2 get 2 2array 2array 3 get instructions>> first (>>inputs)
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[ T{ ##load-tagged f 1 $[ 1 tag-fixnum ] } ]
+[ 1 get instructions>> first ]
+unit-test
+
+[ T{ ##load-tagged f 2 $[ 2 tag-fixnum ] } ]
+[ 2 get instructions>> first ]
+unit-test
+
+! ##load-reference corner case
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##peek f 1 D 1 }
+    T{ ##add f 2 0 1 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-reference f 3 f }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 4 }
+    T{ ##replace f 4 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+1 get 2 2array
+2 get 3 2array 2array 3 get instructions>> first (>>inputs)
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+! Don't untag the f!
+[ 2 ] [ 2 get instructions>> length ] unit-test
+
 cpu x86.32? [
 
     ! Make sure load-constant is converted into load-double
@@ -223,7 +357,7 @@ cpu x86.32? [
 
     V{
         T{ ##peek f 1 D 0 }
-        T{ ##compare-imm-branch f 1 2 }
+        T{ ##compare-imm-branch f 1 2 cc= }
     } 1 test-bb
 
     V{
@@ -268,12 +402,25 @@ cpu x86.32? [
     test-representations
     0 get instructions>> ;
 
-! Converting a ##load-integer into a ##load-tagged
+! Don't convert the def site into anything but tagged-rep since
-V{
+! we might lose precision
-    T{ ##prologue }
+5 \ vreg-counter set-global
-    T{ ##branch }
-} 0 test-bb
 
+[ f ] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 1 }
+        T{ ##add-float f 3 0 0 }
+        T{ ##store-memory-imm f 3 2 0 float-rep f }
+        T{ ##store-memory-imm f 3 2 4 float-rep f }
+        T{ ##mul-float f 4 0 0 }
+        T{ ##replace f 4 D 0 }
+    } test-peephole
+    [ ##single>double-float? ] any?
+] unit-test
+
+! Converting a ##load-integer into a ##load-tagged
 [
     V{
         T{ ##load-tagged f 1 $[ 100 tag-fixnum ] }

basis/compiler/cfg/representations/representations.factor

@@ -3,10 +3,12 @@
 USING: accessors combinators namespaces
 compiler.cfg
 compiler.cfg.registers
+compiler.cfg.predecessors
 compiler.cfg.loop-detection
 compiler.cfg.representations.rewrite
 compiler.cfg.representations.peephole
-compiler.cfg.representations.selection ;
+compiler.cfg.representations.selection
+compiler.cfg.representations.coalescing ;
 IN: compiler.cfg.representations
 
 ! Virtual register representation selection. This is where
@@ -16,12 +18,12 @@ IN: compiler.cfg.representations
 
 : select-representations ( cfg -- cfg' )
     needs-loops
+    needs-predecessors
 
     {
+        [ compute-components ]
         [ compute-possibilities ]
-        [ compute-restrictions ]
         [ compute-representations ]
-        [ compute-phi-representations ]
         [ insert-conversions ]
         [ ]
     } cleave

basis/compiler/cfg/representations/rewrite/rewrite.factor

@@ -85,6 +85,8 @@ GENERIC: conversions-for-insn ( insn -- )
 
 M: ##phi conversions-for-insn , ;
 
+M: ##copy conversions-for-insn , ;
+
 M: insn conversions-for-insn , ;
 
 : conversions-for-block ( bb -- )

basis/compiler/cfg/representations/selection/selection.factor

@@ -1,37 +1,71 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.cfg compiler.cfg.instructions
+USING: accessors arrays assocs byte-arrays combinators
-compiler.cfg.loop-detection compiler.cfg.registers
+disjoint-sets fry kernel locals math namespaces sequences sets
-compiler.cfg.representations.preferred compiler.cfg.rpo
+compiler.cfg
-compiler.cfg.utilities compiler.utilities cpu.architecture
+compiler.cfg.instructions
-deques dlists fry kernel locals math namespaces sequences sets ;
+compiler.cfg.loop-detection
+compiler.cfg.registers
+compiler.cfg.representations.preferred
+compiler.cfg.representations.coalescing
+compiler.cfg.rpo
+compiler.cfg.utilities
+compiler.utilities
+cpu.architecture ;
 FROM: namespaces => set ;
 IN: compiler.cfg.representations.selection
 
-! For every vreg, compute possible representations.
+SYMBOL: scc-infos
+
+TUPLE: scc-info reps all-uses-untagged? ;
+
+: <scc-info> ( -- reps )
+    V{ } clone t \ scc-info boa ;
+
+: scc-info ( vreg -- info )
+    vreg>scc scc-infos get [ drop <scc-info> ] cache ;
+
+: handle-def ( vreg rep -- )
+    swap scc-info reps>> push ;
+
+: handle-use ( vreg rep -- )
+    int-rep eq? [ scc-info f >>all-uses-untagged? ] unless drop ;
+
+GENERIC: collect-scc-info ( insn -- )
+
+M: ##load-reference collect-scc-info
+    [ dst>> ] [ obj>> ] bi {
+        { [ dup float? ] [ drop { float-rep double-rep } ] }
+        { [ dup byte-array? ] [ drop vector-reps ] }
+        [ drop { } ]
+    } cond handle-def ;
+
+M: vreg-insn collect-scc-info
+    [ [ handle-use ] each-use-rep ]
+    [ [ 1array handle-def ] each-def-rep ]
+    [ [ 1array handle-def ] each-temp-rep ]
+    tri ;
+
+M: insn collect-scc-info drop ;
+
+: collect-scc-infos ( cfg -- )
+    H{ } clone scc-infos set
+    [ [ collect-scc-info ] each-non-phi ] each-basic-block ;
+
 SYMBOL: possibilities
 
-: possible ( vreg -- reps ) possibilities get at ;
+: permitted-reps ( scc-info -- seq )
+    reps>> [ ] [ intersect ] map-reduce
+    tagged-rep over member-eq? [ tagged-rep suffix ] unless ;
+
+: scc-reps ( scc-info -- seq )
+    dup permitted-reps
+    2dup [ all-uses-untagged?>> ] [ { tagged-rep } = ] bi* and
+    [ 2drop { tagged-rep int-rep } ] [ nip ] if ;
 
 : compute-possibilities ( cfg -- )
-    H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
+    collect-scc-infos
-    [ members ] assoc-map possibilities set ;
+    scc-infos get [ scc-reps ] assoc-map possibilities set ;
-
-! Compute vregs for which dereferencing cannot be hoisted past
-! conditionals, because they might be immediate.
-:: check-restriction ( vreg rep -- )
-    rep tagged-rep eq? [
-        vreg possibilities get
-        [ { tagged-rep int-rep } intersect ] change-at
-    ] when ;
-
-: compute-restrictions ( cfg -- )
-    [
-        [
-            dup ##load-reference?
-            [ drop ] [ [ check-restriction ] each-def-rep ] if
-        ] each-non-phi
-    ] each-basic-block ;
 
 ! For every vreg, compute the cost of keeping it in every possible
 ! representation.
@@ -45,16 +79,20 @@ SYMBOL: costs
 
 : 10^ ( n -- x ) 10 <repetition> product ;
 
-: increase-cost ( rep vreg factor -- )
+: increase-cost ( rep scc factor -- )
     ! Increase cost of keeping vreg in rep, making a choice of rep less
     ! likely. If the rep is not in the cost alist, it means this
     ! representation is prohibited.
     [ costs get at 2dup key? ] dip
     '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
 
+: possible-reps ( scc -- reps )
+    possibilities get at ;
+
 :: increase-costs ( vreg preferred factor -- )
-    vreg possible [
+    vreg vreg>scc :> scc
-        dup preferred eq? [ drop ] [ vreg factor increase-cost ] if
+    scc possible-reps [
+        dup preferred eq? [ drop ] [ scc factor increase-cost ] if
     ] each ; inline
 
 UNION: inert-tag-untag-insn
@@ -98,11 +136,7 @@ M: vreg-insn compute-insn-costs
     init-costs
     [
         [ basic-block set ]
-        [
+        [ [ compute-insn-costs ] each-non-phi ] bi
-            [
-                compute-insn-costs
-            ] each-non-phi
-        ] bi
     ] each-basic-block ;
 
 ! For every vreg, compute preferred representation, that minimizes costs.
@@ -111,52 +145,7 @@ M: vreg-insn compute-insn-costs
     [ >alist alist-min first ] assoc-map ;
 
 : compute-representations ( cfg -- )
-    compute-costs costs get minimize-costs representations set ;
+    compute-costs costs get minimize-costs
-
+    [ components get [ disjoint-set-members ] keep ] dip
-! PHI nodes require special treatment
+    '[ dup _ representative _ at ] H{ } map>assoc
-! If the output of a phi instruction is only used as the input to another
+    representations set ;
-! phi instruction, then we want to use the same representation for both
-! if possible.
-SYMBOL: phis
-
-: collect-phis ( cfg -- )
-    H{ } clone phis set
-    [
-        phis get
-        '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
-    ] each-basic-block ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( vregs -- )
-    work-list get push-all-front ;
-
-: rep-assigned ( vregs -- vregs' )
-    representations get '[ _ key? ] filter ;
-
-: rep-not-assigned ( vregs -- vregs' )
-    representations get '[ _ key? not ] filter ;
-
-: add-ready-phis ( -- )
-    phis get keys rep-assigned add-to-work-list ;
-
-: process-phi ( dst -- )
-    ! If dst = phi(src1,src2,...) and dst's representation has been
-    ! determined, assign that representation to each one of src1,...
-    ! that does not have a representation yet, and process those, too.
-    dup phis get at* [
-        [ rep-of ] [ rep-not-assigned ] bi*
-        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
-    ] [ 2drop ] if ;
-
-: remaining-phis ( -- )
-    phis get keys rep-not-assigned { } assert-sequence= ;
-
-: process-phis ( -- )
-    <hashed-dlist> work-list set
-    add-ready-phis
-    work-list get [ process-phi ] slurp-deque
-    remaining-phis ;
-
-: compute-phi-representations ( cfg -- )
-    collect-phis process-phis ;

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

@@ -2302,11 +2302,14 @@ V{
 } 3 test-bb
 
 V{
-    T{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
+    T{ ##phi f 3 }
     T{ ##replace f 3 D 0 }
     T{ ##return }
 } 4 test-bb
 
+2 get 1 2array
+3 get 2 2array 2array 4 get instructions>> first (>>inputs)
+
 test-diamond
 
 [ ] [

basis/cpu/architecture/architecture.factor

@@ -87,6 +87,20 @@ UNION: vector-rep
 int-vector-rep
 float-vector-rep ;
 
+CONSTANT: vector-reps
+    {
+        char-16-rep
+        uchar-16-rep
+        short-8-rep
+        ushort-8-rep
+        int-4-rep
+        uint-4-rep
+        longlong-2-rep
+        ulonglong-2-rep
+        float-4-rep
+        double-2-rep
+    }
+
 UNION: representation
 any-rep
 tagged-rep

basis/disjoint-sets/disjoint-sets.factor

@@ -74,6 +74,10 @@ GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
 
 M: disjoint-set disjoint-set-member? parents>> key? ;
 
+GENERIC: disjoint-set-members ( disjoint-set -- seq )
+
+M: disjoint-set disjoint-set-members parents>> keys ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;