Register allocation now uses SSA properties to coalesce values with different representations

basis/compiler/cfg/finalization/finalization.factor

@@ -10,5 +10,4 @@ IN: compiler.cfg.finalization
     insert-gc-checks
     insert-save-contexts
     destruct-ssa
-    delete-empty-blocks
     linear-scan ;

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

@@ -129,9 +129,11 @@ SYMBOL: unhandled-sync-points
 SYMBOL: spill-slots
 
 : assign-spill-slot ( coalesced-vreg rep -- spill-slot )
+    dup tagged-rep? [ drop int-rep ] when
     spill-slots get [ nip next-spill-slot ] 2cache ;
 
 : lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
+    dup tagged-rep? [ drop int-rep ] when
     2array spill-slots get ?at [ ] [ bad-vreg ] if ;
 
 : init-allocator ( registers -- )

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

@@ -6,8 +6,10 @@ cpu.architecture layouts
 compiler.cfg
 compiler.cfg.def-use
 compiler.cfg.liveness
+compiler.cfg.liveness.ssa
 compiler.cfg.registers
 compiler.cfg.instructions
+compiler.cfg.ssa.destruction
 compiler.cfg.renaming.functor
 compiler.cfg.linearization.order
 compiler.cfg.linear-scan.allocation
@@ -29,23 +31,16 @@ SYMBOL: pending-interval-assoc
 : remove-pending ( live-interval -- )
     vreg>> pending-interval-assoc get delete-at ;
 
-ERROR: bad-vreg vreg ;
+:: vreg>reg ( vreg -- reg )
-
-:: (vreg>reg) ( vreg pending -- reg )
     ! If a live vreg is not in the pending set, then it must
     ! have been spilled.
-    vreg pending at* [
+    vreg leader :> leader
-        drop vreg vreg rep-of lookup-spill-slot
+    leader pending-interval-assoc get at* [
+        drop leader vreg rep-of lookup-spill-slot
     ] unless ;
 
-: vreg>reg ( vreg -- reg )
-    pending-interval-assoc get (vreg>reg) ;
-
 : vregs>regs ( vregs -- assoc )
-    dup assoc-empty? [
+    [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
-        pending-interval-assoc get
-        '[ _ (vreg>reg) ] assoc-map
-    ] unless ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -56,18 +51,45 @@ SYMBOL: unhandled-intervals
 : init-unhandled ( live-intervals -- )
     [ add-unhandled ] each ;
 
+! Liveness info is used by resolve pass
+
 ! Mapping from basic blocks to values which are live at the start
-SYMBOL: register-live-ins
+! on all incoming CFG edges
+SYMBOL: machine-live-ins
+
+: machine-live-in ( bb -- assoc )
+    machine-live-ins get at ;
+
+: compute-live-in ( bb -- )
+    [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
+
+! Mapping from basic blocks to predecessors to values which are
+! live on a particular incoming edge
+SYMBOL: machine-edge-live-ins
+
+: machine-edge-live-in ( predecessor bb -- assoc )
+    machine-edge-live-ins get at at ;
+
+: compute-edge-live-in ( bb -- )
+    [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
+    machine-edge-live-ins get set-at ;
 
 ! Mapping from basic blocks to values which are live at the end
-SYMBOL: register-live-outs
+SYMBOL: machine-live-outs
+
+: machine-live-out ( bb -- assoc )
+    machine-live-outs get at ;
+
+: compute-live-out ( bb -- )
+    [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
 
 : init-assignment ( live-intervals -- )
     <min-heap> pending-interval-heap set
     H{ } clone pending-interval-assoc set
     <min-heap> unhandled-intervals set
-    H{ } clone register-live-ins set
+    H{ } clone machine-live-ins set
-    H{ } clone register-live-outs set
+    H{ } clone machine-edge-live-ins set
+    H{ } clone machine-live-outs set
     init-unhandled ;
 
 : insert-spill ( live-interval -- )
@@ -135,18 +157,12 @@ M: ##call-gc assign-registers-in-insn
 M: insn assign-registers-in-insn drop ;
 
 : begin-block ( bb -- )
-    dup basic-block set
+    {
-    dup block-from activate-new-intervals
+        [ basic-block set ]
-    [ live-in vregs>regs ] keep register-live-ins get set-at ;
+        [ block-from activate-new-intervals ]
-
+        [ compute-edge-live-in ]
-: end-block ( bb -- )
+        [ compute-live-in ]
-    [ live-out vregs>regs ] keep register-live-outs get set-at ;
+    } cleave ;
-
-: vreg-at-start ( vreg bb -- state )
-    register-live-ins get at ?at [ bad-vreg ] unless ;
-
-: vreg-at-end ( vreg bb -- state )
-    register-live-outs get at ?at [ bad-vreg ] unless ;
 
 :: assign-registers-in-block ( bb -- )
     bb [
@@ -160,7 +176,7 @@ M: insn assign-registers-in-insn drop ;
                     [ , ]
                 } cleave
             ] each
-            bb end-block
+            bb compute-live-out
         ] V{ } make
     ] change-instructions drop ;
 

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

@@ -1,10 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make locals
 cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.numbering
@@ -29,8 +28,9 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
+! SSA liveness must have been computed already
+
 :: (linear-scan) ( cfg machine-registers -- )
-    cfg compute-live-sets
     cfg number-instructions
     cfg compute-live-intervals machine-registers allocate-registers
     cfg assign-registers

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -2,9 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors locals sequences math
 math.order fry combinators binary-search
-compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.instructions
-compiler.cfg.def-use compiler.cfg.liveness
+compiler.cfg.registers
+compiler.cfg.def-use
+compiler.cfg.liveness
 compiler.cfg.linearization.order
+compiler.cfg.ssa.destruction
 compiler.cfg
 cpu.architecture ;
 IN: compiler.cfg.linear-scan.live-intervals
@@ -87,27 +90,28 @@ SYMBOLS: from to ;
 SYMBOL: live-intervals
 
 : live-interval ( vreg -- live-interval )
-    live-intervals get [ dup rep-of reg-class-of <live-interval> ] cache ;
+    leader live-intervals get
+    [ dup rep-of reg-class-of <live-interval> ] cache ;
 
 GENERIC: compute-live-intervals* ( insn -- )
 
 M: insn compute-live-intervals* drop ;
 
-:: handle-output ( vreg n type -- )
+:: record-def ( vreg n type -- )
     vreg rep-of :> rep
     vreg live-interval :> live-interval
 
     n live-interval shorten-range
     rep n type live-interval add-use ;
 
-:: handle-input ( vreg n type -- )
+:: record-use ( vreg n type -- )
     vreg rep-of :> rep
     vreg live-interval :> live-interval
 
     from get n live-interval add-range
     rep n type live-interval add-use ;
 
-:: handle-temp ( vreg n -- )
+:: record-temp ( vreg n -- )
     vreg rep-of :> rep
     vreg live-interval :> live-interval
 
@@ -117,16 +121,16 @@ M: insn compute-live-intervals* drop ;
 M:: vreg-insn compute-live-intervals* ( insn -- )
     insn insn#>> :> n
 
-    insn defs-vreg [ n +def+ handle-output ] when*
+    insn defs-vreg [ n +def+ record-def ] when*
-    insn uses-vregs [ n +use+ handle-input ] each
+    insn uses-vregs [ n +use+ record-use ] each
-    insn temp-vregs [ n handle-temp ] each ;
+    insn temp-vregs [ n record-temp ] each ;
 
 M:: clobber-insn compute-live-intervals* ( insn -- )
     insn insn#>> :> n
 
-    insn defs-vreg [ n +use+ handle-output ] when*
+    insn defs-vreg [ n +use+ record-def ] when*
-    insn uses-vregs [ n +memory+ handle-input ] each
+    insn uses-vregs [ n +memory+ record-use ] each
-    insn temp-vregs [ n handle-temp ] each ;
+    insn temp-vregs [ n record-temp ] each ;
 
 : handle-live-out ( bb -- )
     live-out dup assoc-empty? [ drop ] [

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

@@ -12,6 +12,7 @@ compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.parallel-copy
+compiler.cfg.ssa.destruction
 compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.resolve
@@ -40,14 +41,22 @@ SYMBOL: spill-temps
 : add-mapping ( from to rep -- )
     '[ _ <location> ] bi@ 2array , ;
 
-:: resolve-value-data-flow ( bb to vreg -- )
+:: resolve-value-data-flow ( vreg live-out live-in edge-live-in -- )
-    vreg bb vreg-at-end
+    vreg live-out ?at [ bad-vreg ] unless
-    vreg to vreg-at-start
+    vreg live-in ?at [ edge-live-in ?at [ bad-vreg ] unless ] unless
     2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
 
-: compute-mappings ( bb to -- mappings )
+:: compute-mappings ( bb to -- mappings )
-    dup live-in dup assoc-empty? [ 3drop f ] [
+    bb machine-live-out :> live-out
-        [ keys [ resolve-value-data-flow ] with with each ] { } make
+    to machine-live-in :> live-in
+    bb to machine-edge-live-in :> edge-live-in
+    live-out assoc-empty? [ f ] [
+        [
+            live-in keys edge-live-in keys append [
+                live-out live-in edge-live-in
+                resolve-value-data-flow
+            ] each
+        ] { } make
     ] if ;
 
 : memory->register ( from to -- )

basis/compiler/cfg/liveness/ssa/ssa-tests.factor

@@ -0,0 +1,65 @@
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.liveness.ssa
+compiler.cfg.liveness arrays sequences assocs
+compiler.cfg.registers kernel namespaces tools.test ;
+IN: compiler.cfg.liveness.ssa.tests
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 0 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##load-integer f 1 1 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f 2 }
+    T{ ##branch }
+} 4 test-bb
+
+2 get 0 2array
+3 get 1 2array 2array
+4 get instructions>> first (>>inputs)
+
+V{
+    T{ ##branch }
+} 5 test-bb
+
+V{
+    T{ ##replace f 2 D 0 }
+    T{ ##branch }
+} 6 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 7 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 { 5 6 } edges
+5 6 edge
+6 7 edge
+
+[ ] [ cfg new 0 get >>entry dup cfg set compute-ssa-live-sets ] unit-test
+
+[ t ] [ 0 get live-in assoc-empty? ] unit-test
+
+[ H{ { 2 2 } } ] [ 4 get live-out ] unit-test
+
+[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test
+
+[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test

basis/compiler/cfg/liveness/ssa/ssa.factor

@@ -11,9 +11,9 @@ IN: compiler.cfg.liveness.ssa
 
 ! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
 ! is in correspondence with a predecessor
-SYMBOL: phi-live-ins
+SYMBOL: edge-live-ins
 
-: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+: edge-live-in ( predecessor basic-block -- set ) edge-live-ins get at at ;
 
 SYMBOL: work-list
 
@@ -23,19 +23,19 @@ SYMBOL: work-list
 : compute-live-in ( basic-block -- live-in )
     [ live-out ] keep instructions>> transfer-liveness ;
 
-: compute-phi-live-in ( basic-block -- phi-live-in )
+: compute-edge-live-in ( basic-block -- edge-live-in )
     H{ } clone [
         '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
     ] keep ;
 
 : update-live-in ( basic-block -- changed? )
     [ [ compute-live-in ] keep live-ins get maybe-set-at ]
-    [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
+    [ [ compute-edge-live-in ] keep edge-live-ins get maybe-set-at ]
     bi or ;
 
 : compute-live-out ( basic-block -- live-out )
     [ successors>> [ live-in ] map ]
-    [ dup successors>> [ phi-live-in ] with map ] bi
+    [ dup successors>> [ edge-live-in ] with map ] bi
     append assoc-combine ;
 
 : update-live-out ( basic-block -- changed? )
@@ -53,7 +53,7 @@ SYMBOL: work-list
 
     <hashed-dlist> work-list set
     H{ } clone live-ins set
-    H{ } clone phi-live-ins set
+    H{ } clone edge-live-ins set
     H{ } clone live-outs set
     post-order add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;

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

@@ -3,9 +3,9 @@
 USING: accessors arrays assocs fry kernel namespaces
 sequences sequences.deep
 sets vectors
+cpu.architecture
 compiler.cfg.rpo
 compiler.cfg.def-use
-compiler.cfg.renaming
 compiler.cfg.registers
 compiler.cfg.dominance
 compiler.cfg.instructions
@@ -18,27 +18,38 @@ compiler.utilities ;
 FROM: namespaces => set ;
 IN: compiler.cfg.ssa.destruction
 
-! Maps vregs to leaders.
+! Because of the design of the register allocator, this pass
+! has three peculiar properties.
+!
+! 1) Instead of renaming vreg usages in the CFG, a map from
+! vregs to canonical representatives is computed. This allows
+! the register allocator to use the original SSA names to get
+! reaching definitions.
+! 2) Useless ##copy instructions, and all ##phi instructions,
+! are eliminated, so the register allocator does not have to
+! remove any redundant operations.
+! 3) A side effect of running this pass is that SSA liveness
+! information is computed, so the register allocator does not
+! need to compute it again.
+
 SYMBOL: leader-map
 
 : leader ( vreg -- vreg' ) leader-map get compress-path ;
 
-! Maps basic blocks to ##phi instruction outputs
-SYMBOL: phi-sets
-
-: phi-set ( bb -- vregs ) phi-sets get at ;
-
 ! Maps leaders to equivalence class elements.
 SYMBOL: class-element-map
 
 : class-elements ( vreg -- elts ) class-element-map get at ;
 
+<PRIVATE
+
 ! Sequence of vreg pairs
 SYMBOL: copies
 
 : init-coalescing ( -- )
-    H{ } clone leader-map set
+    defs get keys
-    H{ } clone class-element-map set
+    [ [ dup ] H{ } map>assoc leader-map set ]
+    [ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
     V{ } clone copies set ;
 
 : classes-interfere? ( vreg1 vreg2 -- ? )
@@ -61,25 +72,27 @@ SYMBOL: copies
         2bi
     ] if ;
 
-: introduce-vreg ( vreg -- )
-    [ leader-map get conjoin ]
-    [ [ 1vector ] keep class-element-map get set-at ] bi ;
-
 GENERIC: prepare-insn ( insn -- )
 
 : try-to-coalesce ( dst src -- ) 2array copies get push ;
 
 M: insn prepare-insn
-    [ defs-vreg ] [ uses-vregs ] bi
+    [ temp-vregs [ leader-map get conjoin ] each ]
-    2dup empty? not and [
+    [
-        first
+        [ defs-vreg ] [ uses-vregs ] bi
-        2dup [ rep-of ] bi@ eq?
+        2dup empty? not and [
-        [ try-to-coalesce ] [ 2drop ] if
+            first
-    ] [ 2drop ] if ;
+            2dup [ rep-of ] bi@ eq?
+            [ try-to-coalesce ] [ 2drop ] if
+        ] [ 2drop ] if
+    ] bi ;
 
 M: ##copy prepare-insn
     [ dst>> ] [ src>> ] bi try-to-coalesce ;
 
+M: ##tagged>integer prepare-insn
+    [ dst>> ] [ src>> ] bi eliminate-copy ;
+
 M: ##phi prepare-insn
     [ dst>> ] [ inputs>> values ] bi
     [ eliminate-copy ] with each ;
@@ -89,7 +102,6 @@ M: ##phi prepare-insn
 
 : prepare-coalescing ( cfg -- )
     init-coalescing
-    defs get keys [ introduce-vreg ] each
     [ prepare-block ] each-basic-block ;
 
 : process-copies ( -- )
@@ -98,34 +110,26 @@ M: ##phi prepare-insn
         [ 2drop ] [ eliminate-copy ] if
     ] assoc-each ;
 
-GENERIC: rename-insn ( insn -- keep? )
+GENERIC: useful-insn? ( insn -- ? )
 
-M: vreg-insn rename-insn
+: useful-copy? ( insn -- ? )
-    [ rename-insn-defs ] [ rename-insn-uses ] bi t ;
+    [ dst>> leader ] [ src>> leader ] bi eq? not ; inline
 
-M: ##copy rename-insn
+M: ##copy useful-insn? useful-copy? ;
-    [ call-next-method drop ]
-    [ [ dst>> ] [ src>> ] bi eq? not ] bi ;
 
-SYMBOL: current-phi-set
+M: ##tagged>integer useful-insn? useful-copy? ;
 
-M: ##phi rename-insn dst>> current-phi-set get push f ;
+M: ##phi useful-insn? drop f ;
 
-M: ##call-gc rename-insn
+M: insn useful-insn? drop t ;
-    [ renamings get '[ _ at ] map members ] change-gc-roots drop t ;
 
-M: insn rename-insn drop t ;
+: cleanup-block ( bb -- )
+    instructions>> [ useful-insn? ] filter! drop ;
 
-: renaming-in-block ( bb -- )
+: cleanup-cfg ( cfg -- )
-    V{ } clone current-phi-set set
+    [ cleanup-block ] each-basic-block ;
-    [ [ current-phi-set ] dip phi-sets get set-at ]
-    [ instructions>> [ rename-insn ] filter! drop ]
-    bi ;
 
-: perform-renaming ( cfg -- )
+PRIVATE>
-    H{ } clone phi-sets set
-    leader-map get keys [ dup leader ] H{ } map>assoc renamings set
-    [ renaming-in-block ] each-basic-block ;
 
 : destruct-ssa ( cfg -- cfg' )
     needs-dominance
@@ -136,4 +140,4 @@ M: insn rename-insn drop t ;
     dup compute-live-ranges
     dup prepare-coalescing
     process-copies
-    dup perform-renaming ;
+    dup cleanup-cfg ;

basis/cpu/x86/32/32.factor

@@ -346,8 +346,7 @@ M: x86.32 %cleanup ( params -- )
 
 M:: x86.32 %call-gc ( gc-roots -- )
     4 save-vm-ptr
-    EAX gc-roots gc-root-offsets %load-reference
+    0 stack@ gc-roots gc-root-offsets %load-reference
-    0 stack@ EAX MOV
     "inline_gc" f %alien-invoke ;
 
 M: x86.32 dummy-stack-params? f ;