1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators compiler.cfg
4 compiler.cfg.linearization compiler.cfg.liveness compiler.cfg.registers
5 compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
6 compiler.cfg.linear-scan.live-intervals compiler.cfg.renaming.functor
7 compiler.cfg.ssa.destruction.leaders cpu.architecture
8 fry heaps kernel make math namespaces sequences sets ;
9 IN: compiler.cfg.linear-scan.assignment
11 ! This contains both active and inactive intervals; any interval
12 ! such that start <= insn# <= end is in this set.
13 SYMBOL: pending-interval-heap
14 SYMBOL: pending-interval-assoc
16 : add-pending ( live-interval -- )
17 [ dup end>> pending-interval-heap get heap-push ]
18 [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
21 : remove-pending ( live-interval -- )
22 vreg>> pending-interval-assoc get delete-at ;
24 : vreg>reg ( vreg -- reg/spill-slot )
25 dup leader dup pending-interval-assoc get at
26 [ 2nip ] [ swap rep-of lookup-spill-slot ] if* ;
28 ERROR: not-spilled-error vreg ;
30 : vreg>spill-slot ( vreg -- spill-slot )
31 dup vreg>reg dup spill-slot?
33 [ drop leader throw-not-spilled-error ] if ;
35 : vregs>regs ( vregs -- assoc )
36 [ dup vreg>reg ] H{ } map>assoc ;
38 SYMBOL: unhandled-intervals
40 SYMBOL: machine-live-ins
42 : machine-live-in ( bb -- assoc )
43 machine-live-ins get at ;
45 : compute-live-in ( bb -- )
46 [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
48 SYMBOL: machine-edge-live-ins
50 : machine-edge-live-in ( predecessor bb -- assoc )
51 machine-edge-live-ins get at at ;
53 : compute-edge-live-in ( bb -- )
54 [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
55 machine-edge-live-ins get set-at ;
57 SYMBOL: machine-live-outs
59 : machine-live-out ( bb -- assoc )
60 machine-live-outs get at ;
62 : compute-live-out ( bb -- )
63 [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
65 : heap-pop-while ( heap quot: ( key -- ? ) -- values )
66 '[ dup heap-empty? [ f f ] [ dup heap-peek @ ] if ]
67 [ over heap-pop* ] produce 2nip ; inline
69 : insert-spill ( live-interval -- )
70 [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
72 : handle-spill ( live-interval -- )
73 dup spill-to>> [ insert-spill ] [ drop ] if ;
75 : expire-interval ( live-interval -- )
76 [ remove-pending ] [ handle-spill ] bi ;
78 : expire-old-intervals ( n -- )
79 pending-interval-heap get swap '[ _ < ] heap-pop-while
80 [ expire-interval ] each ;
82 : insert-reload ( live-interval -- )
83 [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
85 : handle-reload ( live-interval -- )
86 dup reload-from>> [ insert-reload ] [ drop ] if ;
88 : activate-interval ( live-interval -- )
89 [ add-pending ] [ handle-reload ] bi ;
91 : activate-new-intervals ( n -- )
92 unhandled-intervals get swap '[ _ = ] heap-pop-while
93 [ activate-interval ] each ;
95 : prepare-insn ( n -- )
96 [ expire-old-intervals ] [ activate-new-intervals ] bi ;
98 GENERIC: assign-registers-in-insn ( insn -- )
100 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
102 M: vreg-insn assign-registers-in-insn
103 [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
105 : assign-gc-roots ( gc-map -- )
106 [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
108 : assign-derived-roots ( gc-map -- )
109 [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
111 M: gc-map-insn assign-registers-in-insn
112 [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
113 [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ]
116 M: insn assign-registers-in-insn drop ;
118 : begin-block ( bb -- )
121 [ block-from activate-new-intervals ]
122 [ compute-edge-live-in ]
126 : assign-registers-in-block ( bb -- )
132 [ insn#>> 1 - prepare-insn ]
133 [ insn#>> prepare-insn ]
134 [ assign-registers-in-insn ]
139 ] change-instructions compute-live-out ;
141 : init-assignment ( live-intervals -- )
142 [ [ start>> ] map ] keep zip >min-heap unhandled-intervals set
143 <min-heap> pending-interval-heap set
144 H{ } clone pending-interval-assoc set
145 H{ } clone machine-live-ins set
146 H{ } clone machine-edge-live-ins set
147 H{ } clone machine-live-outs set ;
149 : assign-registers ( cfg live-intervals -- )
151 linearization-order [ kill-block?>> ] reject
152 [ assign-registers-in-block ] each ;