1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: namespaces sequences math math.order kernel assocs
4 accessors vectors fry heaps cpu.architecture combinators
6 compiler.cfg.linear-scan.live-intervals ;
7 IN: compiler.cfg.linear-scan.allocation
9 ! Mapping from register classes to sequences of machine registers
10 SYMBOL: free-registers
12 : free-registers-for ( vreg -- seq )
13 reg-class>> free-registers get at ;
15 : deallocate-register ( live-interval -- )
16 [ reg>> ] [ vreg>> ] bi free-registers-for push ;
18 ! Vector of active live intervals
19 SYMBOL: active-intervals
21 : active-intervals-for ( vreg -- seq )
22 reg-class>> active-intervals get at ;
24 : add-active ( live-interval -- )
25 dup vreg>> active-intervals-for push ;
27 : delete-active ( live-interval -- )
28 dup vreg>> active-intervals-for delq ;
30 : expire-old-intervals ( n -- )
31 active-intervals swap '[
33 [ end>> _ < ] partition
34 [ [ deallocate-register ] each ] dip
38 ! Minheap of live intervals which still need a register allocation
39 SYMBOL: unhandled-intervals
41 ! Start index of current live interval. We ensure that all
42 ! live intervals added to the unhandled set have a start index
43 ! strictly greater than ths one. This ensures that we can catch
44 ! infinite loop situations.
47 : check-progress ( live-interval -- )
48 start>> progress get <= [ "No progress" throw ] when ; inline
50 : add-unhandled ( live-interval -- )
52 [ dup start>> unhandled-intervals get heap-push ]
55 : init-unhandled ( live-intervals -- )
56 [ [ start>> ] keep ] { } map>assoc
57 unhandled-intervals get heap-push-all ;
60 : active-interval ( vreg -- live-interval )
61 dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
63 : coalesce? ( live-interval -- ? )
64 [ start>> ] [ copy-from>> active-interval ] bi
65 dup [ end>> = ] [ 2drop f ] if ;
67 : coalesce ( live-interval -- )
68 dup copy-from>> active-interval
69 [ [ add-active ] [ delete-active ] bi* ]
74 : find-use ( live-interval n quot -- i elt )
75 [ uses>> ] 2dip curry find ; inline
77 : split-before ( live-interval i -- before )
78 [ clone dup uses>> ] dip
79 [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
81 : split-after ( live-interval i -- after )
82 [ clone dup uses>> ] dip
83 [ tail >>uses ] [ swap nth >>start ] 2bi
84 f >>reg f >>copy-from ;
86 : split-interval ( live-interval n -- before after )
87 [ drop ] [ [ > ] find-use drop ] 2bi
88 [ split-before ] [ split-after ] 2bi ;
90 : record-split ( live-interval before after -- )
91 [ >>split-before ] [ >>split-after ] bi* drop ;
96 : next-spill-location ( reg-class -- n )
97 spill-counts get [ dup 1+ ] change-at ;
99 : interval-to-spill ( active-intervals current -- live-interval )
100 #! We spill the interval with the most distant use location.
101 start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
102 unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
104 : assign-spill ( before after -- before after )
105 #! If it has been spilled already, reuse spill location.
107 [ over vreg>> reg-class>> next-spill-location ] unless*
108 [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
110 : split-and-spill ( new existing -- before after )
111 dup rot start>> split-interval
112 [ record-split ] [ assign-spill ] 2bi ;
114 : reuse-register ( new existing -- )
115 reg>> >>reg add-active ;
117 : spill-existing ( new existing -- )
118 #! Our new interval will be used before the active interval
119 #! with the most distant use location. Spill the existing
120 #! interval, then process the new interval and the tail end
121 #! of the existing interval again.
123 [ nip delete-active ]
124 [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
126 : spill-new ( new existing -- )
127 #! Our new interval will be used after the active interval
128 #! with the most distant use location. Split the new
129 #! interval, then process both parts of the new interval
131 [ dup split-and-spill add-unhandled ] dip spill-existing ;
133 : spill-existing? ( new existing -- ? )
134 #! Test if 'new' will be used before 'existing'.
135 over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
137 : assign-blocked-register ( new -- )
138 [ dup vreg>> active-intervals-for ] keep interval-to-spill
139 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
141 : assign-free-register ( new registers -- )
142 pop >>reg add-active ;
144 : assign-register ( new -- )
148 dup vreg>> free-registers-for
149 [ assign-blocked-register ]
150 [ assign-free-register ]
155 : reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
157 : init-allocator ( registers -- )
158 <min-heap> unhandled-intervals set
159 [ reverse >vector ] assoc-map free-registers set
160 reg-classes [ 0 ] { } map>assoc spill-counts set
161 reg-classes [ V{ } clone ] { } map>assoc active-intervals set
164 : handle-interval ( live-interval -- )
165 [ start>> progress set ]
166 [ start>> expire-old-intervals ]
170 : (allocate-registers) ( -- )
171 unhandled-intervals get [ handle-interval ] slurp-heap ;
173 : allocate-registers ( live-intervals machine-registers -- live-intervals )
174 #! This modifies the input live-intervals.
177 (allocate-registers) ;