WIP

basis/compiler/cfg/def-use/def-use.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2011 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs arrays classes combinators
 compiler.units fry generalizations sequences.generalizations
@@ -9,6 +9,9 @@ FROM: namespaces => set ;
 FROM: sets => members ;
 IN: compiler.cfg.def-use
 
+! Utilities for iterating over instruction operands
+
+! Def-use protocol
 GENERIC: defs-vregs ( insn -- seq )
 GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
@@ -17,6 +20,52 @@ M: insn defs-vregs drop { } ;
 M: insn temp-vregs drop { } ;
 M: insn uses-vregs drop { } ;
 
+! Instructions with unusual operands, also see these passes
+! for special behavior:
+! - compiler.cfg.renaming.functor
+! - compiler.cfg.representations.preferred
+CONSTANT: special-vreg-insns {
+    ##parallel-copy
+    ##phi
+    ##alien-invoke
+    ##alien-indirect
+    ##alien-assembly
+    ##callback-inputs
+    ##callback-outputs
+}
+
+! Special defs-vregs methods
+M: ##parallel-copy defs-vregs values>> [ first ] map ;
+
+M: ##phi defs-vregs dst>> 1array ;
+
+M: alien-call-insn defs-vregs
+    reg-outputs>> [ first ] map ;
+
+M: ##callback-inputs defs-vregs
+    [ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
+
+M: ##callback-outputs defs-vregs drop { } ;
+
+! Special uses-vregs methods
+M: ##parallel-copy uses-vregs values>> [ second ] map ;
+
+M: ##phi uses-vregs inputs>> values ;
+
+M: alien-call-insn uses-vregs
+    [ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
+
+M: ##alien-indirect uses-vregs
+    [ call-next-method ] [ src>> ] bi prefix ;
+
+M: ##callback-inputs uses-vregs
+    drop { } ;
+
+M: ##callback-outputs uses-vregs
+    reg-inputs>> [ first ] map ;
+
+! Generate defs-vregs, uses-vregs and temp-vregs for everything
+! else
 <PRIVATE
 
 : slot-array-quot ( slots -- quot )
@@ -45,33 +94,6 @@ M: insn uses-vregs drop { } ;
 
 PRIVATE>
 
-CONSTANT: special-vreg-insns
-{ ##phi ##alien-invoke ##alien-indirect ##alien-assembly ##callback-inputs ##callback-outputs }
-
-M: ##phi defs-vregs dst>> 1array ;
-
-M: alien-call-insn defs-vregs
-    reg-outputs>> [ first ] map ;
-
-M: ##callback-inputs defs-vregs
-    [ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
-
-M: ##callback-outputs defs-vregs drop { } ;
-
-M: ##phi uses-vregs inputs>> values ;
-
-M: alien-call-insn uses-vregs
-    [ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
-
-M: ##alien-indirect uses-vregs
-    [ call-next-method ] [ src>> ] bi prefix ;
-
-M: ##callback-inputs uses-vregs
-    drop { } ;
-
-M: ##callback-outputs uses-vregs
-    reg-inputs>> [ first ] map ;
-
 [
     insn-classes get
     [ special-vreg-insns diff [ define-defs-vregs-method ] each ]
@@ -80,6 +102,7 @@ M: ##callback-outputs uses-vregs
     tri
 ] with-compilation-unit
 
+! Computing vreg -> insn -> bb mapping
 SYMBOLS: defs insns ;
 
 : def-of ( vreg -- node ) defs get at ;

basis/compiler/cfg/instructions/instructions.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2010 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
 math math.order layouts classes.union compiler.units alien
@@ -119,6 +119,10 @@ def: dst
 use: src
 literal: rep ;
 
+! Only used by compiler.cfg.cssa
+FLUSHABLE-INSN: ##parallel-copy
+literal: values ;
+
 FOLDABLE-INSN: ##tagged>integer
 def: dst/int-rep
 use: src/tagged-rep ;

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

@@ -119,7 +119,7 @@ SYMBOL: unhandled-intervals
 : reg-class-assoc ( quot -- assoc )
     [ reg-classes ] dip { } map>assoc ; inline
 
-: next-spill-slot ( size -- n )
+: next-spill-slot ( size -- spill-slot )
     cfg get
     [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
     <spill-slot> ;

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -107,7 +107,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
 ] unit-test
 
 cfg new 8 >>spill-area-size cfg set
-H{ } clone spill-temps set
+init-resolve
 
 [ t ] [
     {

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2009, 2010 Slava Pestov.
+! Copyright (C) 2009, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals namespaces
@@ -33,10 +33,21 @@ M: location equal?
 M: location hashcode*
     reg>> hashcode* ;
 
-SYMBOL: spill-temps
+SYMBOL: temp-spills
 
-: spill-temp ( rep -- n )
+: temp-spill ( rep -- spill-slot )
-    rep-size spill-temps get [ next-spill-slot ] cache ;
+    rep-size temp-spills get
+    [ next-spill-slot ] cache ;
+
+SYMBOL: temp-locations
+
+: temp-location ( loc -- temp )
+    rep>> temp-locations get
+    [ [ temp-spill ] keep <location> ] cache ;
+
+: init-resolve ( -- )
+    H{ } clone temp-spills set
+    H{ } clone temp-locations set ;
 
 : add-mapping ( from to rep -- )
     '[ _ <location> ] bi@ 2array , ;
@@ -74,20 +85,18 @@ SYMBOL: spill-temps
 : register->register ( from to -- )
     swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy, ;
 
-SYMBOL: temp
-
 : >insn ( from to -- )
     {
-        { [ over temp eq? ] [ temp->register ] }
-        { [ dup temp eq? ] [ register->temp ] }
         { [ over reg>> spill-slot? ] [ memory->register ] }
         { [ dup reg>> spill-slot? ] [ register->memory ] }
         [ register->register ]
     } cond ;
 
 : mapping-instructions ( alist -- insns )
-    [ swap ] H{ } assoc-map-as
+    [ swap ] H{ } assoc-map-as [
-    [ temp [ swap >insn ] parallel-mapping ##branch, ] { } make ;
+        [ temp-location ] [ swap >insn ] parallel-mapping
+        ##branch
+    ] { } make ;
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
@@ -105,6 +114,5 @@ SYMBOL: temp
 
 : resolve-data-flow ( cfg -- )
     needs-predecessors
-
+    init-resolve
-    H{ } clone spill-temps set
     [ resolve-block-data-flow ] each-basic-block ;

basis/compiler/cfg/parallel-copy/parallel-copy.factor

@@ -11,7 +11,7 @@ IN: compiler.cfg.parallel-copy
 
 <PRIVATE
 
-SYMBOLS: temp locs preds to-do ready ;
+SYMBOLS: locs preds to-do ready ;
 
 : init-to-do ( bs -- )
     to-do get push-all-back ;
@@ -19,43 +19,59 @@ SYMBOLS: temp locs preds to-do ready ;
 : init-ready ( bs -- )
     locs get '[ _ key? not ] filter ready get push-all-front ;
 
-: init ( mapping temp -- )
+: init ( mapping -- )
-    temp set
     <dlist> to-do set
     <dlist> ready set
     [ preds set ]
     [ [ nip dup ] H{ } assoc-map-as locs set ]
     [ keys [ init-to-do ] [ init-ready ] bi ] tri ;
 
-:: process-ready ( b quot -- )
+:: process-ready ( b quot: ( dst src -- ) -- )
     b preds get at :> a
     a locs get at :> c
     b c quot call
     b a locs get set-at
     a c = a preds get at and [ a ready get push-front ] when ; inline
 
-:: process-to-do ( b quot -- )
+:: process-to-do ( b temp: ( src -- dst ) quot: ( dst src -- ) -- )
     ! Note that we check if b = loc(b), not b = loc(pred(b)) as the
     ! paper suggests. Confirmed by one of the authors at
     ! http://www.reddit.com/comments/93253/some_lecture_notes_on_ssa_form/c0bco4f
     b locs get at b = [
-        temp get b quot call
+        b temp call :> temp
-        temp get b locs get set-at
+        temp b quot call
+        temp b locs get set-at
         b ready get push-front
     ] when ; inline
 
 PRIVATE>
 
-:: parallel-mapping ( mapping temp quot -- )
+:: parallel-mapping ( mapping temp: ( src -- dst ) quot: ( dst src -- ) -- )
+    ! mapping is a list of { dst src } pairs
     [
-        mapping temp init
+        mapping init
         to-do get [
             ready get [
                 quot process-ready
             ] slurp-deque
-            quot process-to-do
+            temp quot process-to-do
         ] slurp-deque
     ] with-scope ; inline
 
 : parallel-copy ( mapping -- )
-    next-vreg [ any-rep ##copy, ] parallel-mapping ;
+    ! mapping is a list of { dst src } pairs
+    next-vreg '[ drop _ ] [ any-rep ##copy ] parallel-mapping ;
+
+<PRIVATE
+
+SYMBOL: temp-vregs
+
+: temp-vreg ( rep -- vreg )
+    temp-vregs get [ next-vreg-rep ] cache ;
+
+PRIVATE>
+
+: parallel-copy-rep ( mapping -- )
+    ! mapping is a list of { dst src } pairs
+    H{ } clone temp-vregs set
+    [ rep-of temp-vreg ] [ dup rep-of ##copy ] parallel-mapping ;

basis/compiler/cfg/renaming/functor/functor.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009, 2010 Slava Pestov.
+! Copyright (C) 2009, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry functors generic.parser
 kernel lexer namespaces parser sequences slots words sets
@@ -6,6 +6,8 @@ compiler.cfg.def-use compiler.cfg.instructions
 compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.renaming.functor
 
+! Like compiler.cfg.def-use, but for changing operands
+
 : slot-change-quot ( slots quot -- quot' )
     '[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
     [ drop ] append ;
@@ -19,34 +21,36 @@ rename-insn-temps DEFINES ${NAME}-insn-temps
 WHERE
 
 GENERIC: rename-insn-defs ( insn -- )
+GENERIC: rename-insn-uses ( insn -- )
+GENERIC: rename-insn-temps ( insn -- )
 
 M: insn rename-insn-defs drop ;
+M: insn rename-insn-uses drop ;
+M: insn rename-insn-temps drop ;
 
-insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [
+! Instructions with unusual operands
-    [ \ rename-insn-defs create-method-in ]
+
-    [ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi
+! Special rename-insn-defs methods
-    define
+M: ##parallel-copy rename-insn-defs
-] each
+    [ [ first2 [ DEF-QUOT ] dip 2array ] map ] change-values ;
 
 M: ##phi rename-insn-defs DEF-QUOT change-dst drop ;
 
 M: alien-call-insn rename-insn-defs
-    [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs drop ;
+    [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs
+    drop ;
 
 M: ##callback-inputs rename-insn-defs
     [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs
     [ [ first3 DEF-QUOT 2dip 3array ] map ] change-stack-outputs
     drop ;
 
-GENERIC: rename-insn-uses ( insn -- )
+! Special rename-insn-uses methods
+M: ##parallel-copy rename-insn-uses
+    [ [ first2 USE-QUOT 2array ] map ] change-values ;
 
-M: insn rename-insn-uses drop ;
+M: ##phi rename-insn-uses
-
+    [ USE-QUOT assoc-map ] change-inputs drop ;
-insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [
-    [ \ rename-insn-uses create-method-in ]
-    [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
-    define
-] each
 
 M: alien-call-insn rename-insn-uses
     [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
@@ -57,14 +61,21 @@ M: ##alien-indirect rename-insn-uses
     USE-QUOT change-src call-next-method ;
 
 M: ##callback-outputs rename-insn-uses
-    [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs drop ;
+    [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
+    drop ;
 
-M: ##phi rename-insn-uses
+! Generate methods for everything else
-    [ USE-QUOT assoc-map ] change-inputs drop ;
+insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [
+    [ \ rename-insn-defs create-method-in ]
+    [ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi
+    define
+] each
 
-GENERIC: rename-insn-temps ( insn -- )
+insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [
-
+    [ \ rename-insn-uses create-method-in ]
-M: insn rename-insn-temps drop ;
+    [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
+    define
+] each
 
 insn-classes get [ insn-temp-slots empty? not ] filter [
     [ \ rename-insn-temps create-method-in ]

basis/compiler/cfg/ssa/cssa/cssa.factor

@@ -1,34 +1,54 @@
-! Copyright (C) 2009, 2010 Slava Pestov.
+! Copyright (C) 2009, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals fry sequences sets
+USING: accessors assocs kernel locals fry make namespaces
-cpu.architecture
+sequences cpu.architecture
+compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.def-use
 compiler.cfg.utilities
+compiler.cfg.predecessors
 compiler.cfg.registers
 compiler.cfg.instructions ;
+FROM: assocs => change-at ;
 IN: compiler.cfg.ssa.cssa
 
 ! Convert SSA to conventional SSA. This pass runs after representation
 ! selection, so it must keep track of representations when introducing
 ! new values.
 
-: insert-copy? ( bb vreg -- ? )
+SYMBOL: copies
-    ! If the last instruction defines a value (which means it is
-    ! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
-    ! need to insert a copy since in fact doing so will result
-    ! in incorrect code.
-    [ instructions>> last defs-vregs ] dip swap in? not ;
 
-:: insert-copy ( bb src rep -- bb dst )
+: init-copies ( bb -- )
-    bb src insert-copy? [
+    predecessors>> [ V{ } clone ] H{ } map>assoc copies set ;
+
+:: convert-operand ( src pred rep -- dst )
     rep next-vreg-rep :> dst
-        bb [ dst src rep ##copy, ] add-instructions
+    { dst src } pred copies get at push
-        bb dst
+    dst ;
-    ] [ bb src ] if ;
 
-: convert-phi ( ##phi -- )
+:: convert-phi ( insn preds -- )
-    dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
+    insn dst>> rep-of :> rep
+    insn inputs>> :> inputs
+    preds [| pred |
+        pred inputs [ pred rep convert-operand ] change-at
+    ] each ;
+
+: insert-edge-copies ( from to copies -- )
+    [ ##parallel-copy ##branch ] { } make insert-basic-block ;
+
+: insert-copies ( bb -- )
+    [ copies get ] dip '[
+        [ drop ] [ [ _ ] dip insert-edge-copies ] if-empty
+    ] assoc-each ;
+
+: convert-phis ( bb -- )
+    [ init-copies ]
+    [ dup predecessors>> '[ _ convert-phi ] each-phi ]
+    [ insert-copies ]
+    tri ;
 
 : construct-cssa ( cfg -- )
-    [ [ convert-phi ] each-phi ] each-basic-block ;
+    needs-predecessors
+
+    dup [ convert-phis ] each-basic-block
+
+    cfg-changed drop ;

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2009, 2010 Slava Pestov.
+! Copyright (C) 2009, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs fry locals kernel namespaces
+USING: accessors arrays assocs fry locals kernel make
-sequences sequences.deep
+namespaces sequences sequences.deep
 sets vectors
 cpu.architecture
 compiler.cfg.rpo
@@ -13,6 +13,7 @@ compiler.cfg.liveness
 compiler.cfg.ssa.cssa
 compiler.cfg.ssa.interference
 compiler.cfg.ssa.interference.live-ranges
+compiler.cfg.parallel-copy
 compiler.cfg.utilities
 compiler.utilities ;
 FROM: namespaces => set ;
@@ -66,15 +67,6 @@ SYMBOL: copies
 : coalesce-vregs ( merged leader1 leader2 -- )
     [ coalesce-leaders ] [ coalesce-elements ] 2bi ;
 
-:: maybe-eliminate-copy ( vreg1 vreg2 -- )
-    ! Eliminate a copy of possible.
-    vreg1 leader :> vreg1
-    vreg2 leader :> vreg2
-    vreg1 vreg2 eq? [
-        vreg1 class-elements vreg2 class-elements sets-interfere?
-        [ drop ] [ vreg1 vreg2 coalesce-vregs ] if
-    ] unless ;
-
 GENERIC: prepare-insn ( insn -- )
 
 : maybe-eliminate-copy-later ( dst src -- )
@@ -96,35 +88,69 @@ M: vreg-insn prepare-insn
 M: ##copy prepare-insn
     [ dst>> ] [ src>> ] bi maybe-eliminate-copy-later ;
 
+M: ##parallel-copy prepare-insn
+    values>> [ first2 maybe-eliminate-copy-later ] each ;
+
+: leaders ( vreg1 vreg2 -- vreg1' vreg2' )
+    [ leader ] bi@ ;
+
+: vregs-interfere? ( vreg1 vreg2 -- merged/f ? )
+    [ class-elements ] bi@ sets-interfere? ;
+
+ERROR: vregs-shouldn't-interfere vreg1 vreg2 ;
+
+:: must-eliminate-copy ( vreg1 vreg2 -- )
+    ! Eliminate a copy.
+    vreg1 vreg2 eq? [
+        vreg1 vreg2 vregs-interfere?
+        [ vreg1 vreg2 vregs-shouldn't-interfere ]
+        [ vreg1 vreg2 coalesce-vregs ]
+        if
+    ] unless ;
+
 M: ##tagged>integer prepare-insn
-    [ dst>> ] [ src>> ] bi maybe-eliminate-copy ;
+    [ dst>> ] [ src>> ] bi leaders must-eliminate-copy ;
 
 M: ##phi prepare-insn
     [ dst>> ] [ inputs>> values ] bi
-    [ maybe-eliminate-copy ] with each ;
+    [ leaders must-eliminate-copy ] with each ;
 
 : prepare-coalescing ( cfg -- )
     init-coalescing
     [ [ prepare-insn ] each ] simple-analysis ;
 
-: process-copies ( -- )
+:: maybe-eliminate-copy ( vreg1 vreg2 -- )
-    copies get [ maybe-eliminate-copy ] assoc-each ;
+    ! Eliminate a copy if possible.
+    vreg1 vreg2 eq? [
+        vreg1 vreg2 vregs-interfere?
+        [ drop ] [ vreg1 vreg2 coalesce-vregs ] if
+    ] unless ;
 
-GENERIC: useful-insn? ( insn -- ? )
+: process-copies ( -- )
+    copies get [ leaders maybe-eliminate-copy ] assoc-each ;
+
+GENERIC: cleanup-insn ( insn -- )
 
 : useful-copy? ( insn -- ? )
-    [ dst>> leader ] [ src>> leader ] bi eq? not ; inline
+    [ dst>> ] [ src>> ] bi leaders eq? not ; inline
 
-M: ##copy useful-insn? useful-copy? ;
+M: ##copy cleanup-insn
+    dup useful-copy? [ , ] [ drop ] if ;
 
-M: ##tagged>integer useful-insn? useful-copy? ;
+M: ##parallel-copy cleanup-insn
+    values>>
+    [ first2 leaders 2array ] map [ first2 eq? not ] filter
+    [ parallel-copy-rep ] unless-empty ;
 
-M: ##phi useful-insn? drop f ;
+M: ##tagged>integer cleanup-insn
+    dup useful-copy? [ , ] [ drop ] if ;
 
-M: insn useful-insn? drop t ;
+M: ##phi cleanup-insn drop ;
+
+M: insn cleanup-insn , ;
 
 : cleanup-cfg ( cfg -- )
-    [ [ useful-insn? ] filter! ] simple-optimization ;
+    [ [ [ cleanup-insn ] each ] V{ } make ] simple-optimization ;
 
 PRIVATE>
 
@@ -138,4 +164,5 @@ PRIVATE>
     dup compute-live-ranges
     dup prepare-coalescing
     process-copies
-    dup cleanup-cfg ;
+    dup cleanup-cfg
+    dup compute-live-sets ;

basis/compiler/tests/codegen.factor

@@ -524,3 +524,16 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
     231 over 1 set-alien-unsigned-1 ;
 
 [ B{ 123 231 } ] [ derived-pointer-test-1 ] unit-test
+
+: fib-count2 ( -- x y ) 0 1 [ dup 4000000 <= ] [ [ + ] keep swap ] while ;
+
+[ 3524578 5702887 ] [ fib-count2 ] unit-test
+
+! Stupid repro
+USE: compiler.cfg.registers
+
+0 vreg-counter set-global
+
+{ fib-count2 } compile
+
+[ 3524578 5702887 ] [ fib-count2 ] unit-test