1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators compiler.cfg
4 compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
5 compiler.cfg.linear-scan.ranges compiler.cfg.registers
6 cpu.architecture heaps kernel math math.order namespaces
8 IN: compiler.cfg.linear-scan.allocation.state
12 : check-unhandled ( live-interval -- )
13 live-interval-start progress get <= [ "check-unhandled" throw ] when ; inline
15 : check-handled ( live-interval -- )
16 live-interval-end progress get > [ "check-handled" throw ] when ; inline
18 SYMBOL: unhandled-min-heap
20 GENERIC: interval/sync-point-key ( interval/sync-point -- key )
22 M: live-interval-state interval/sync-point-key
23 [ ranges>> ranges-endpoints ] [ vreg>> ] bi 3array ;
25 M: sync-point interval/sync-point-key
26 n>> 1/0. 1/0. 3array ;
28 : >unhandled-min-heap ( intervals/sync-points -- min-heap )
29 [ [ interval/sync-point-key ] keep 2array ] map >min-heap ;
33 SYMBOL: active-intervals
35 : active-intervals-for ( live-interval -- seq )
36 interval-reg-class active-intervals get at ;
38 : add-active ( live-interval -- )
39 dup active-intervals-for push ;
41 : delete-active ( live-interval -- )
42 dup active-intervals-for remove-eq! drop ;
44 : assign-free-register ( new registers -- )
45 pop >>reg add-active ;
47 SYMBOL: inactive-intervals
49 : inactive-intervals-for ( live-interval -- seq )
50 interval-reg-class inactive-intervals get at ;
52 : add-inactive ( live-interval -- )
53 dup inactive-intervals-for push ;
55 : delete-inactive ( live-interval -- )
56 dup inactive-intervals-for remove-eq! drop ;
58 SYMBOL: handled-intervals
60 : add-handled ( live-interval -- )
61 [ check-handled ] [ handled-intervals get push ] bi ;
63 : finished? ( n live-interval -- ? ) live-interval-end swap < ;
65 : finish ( n live-interval -- keep? )
68 SYMBOL: check-allocation?
70 ERROR: register-already-used live-interval ;
72 : check-activate ( live-interval -- )
73 check-allocation? get [
74 dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
75 [ register-already-used ] [ drop ] if
78 : activate ( n live-interval -- keep? )
82 : deactivate ( n live-interval -- keep? )
85 : don't-change ( n live-interval -- keep? ) 2drop t ;
87 ! Moving intervals between active and inactive sets
88 : process-intervals ( n symbol quots -- )
89 ! symbol stores an alist mapping register classes to vectors
90 [ get values ] dip '[ [ _ cond ] with filter! drop ] with each ; inline
92 : covers? ( n live-interval -- ? )
93 ranges>> ranges-cover? ;
95 : deactivate-intervals ( n -- )
98 { [ 2dup finished? ] [ finish ] }
99 { [ 2dup covers? not ] [ deactivate ] }
101 } process-intervals ;
103 : activate-intervals ( n -- )
105 { [ 2dup finished? ] [ finish ] }
106 { [ 2dup covers? ] [ activate ] }
108 } process-intervals ;
110 : add-unhandled ( live-interval -- )
112 dup interval/sync-point-key unhandled-min-heap get heap-push ;
114 : reg-class-assoc ( quot -- assoc )
115 [ reg-classes ] dip { } map>assoc ; inline
117 : align-spill-area ( align stack-frame -- )
118 [ max ] change-spill-area-align drop ;
120 : next-spill-slot ( size stack-frame -- spill-slot )
121 [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop <spill-slot> ;
125 : assign-spill-slot ( coalesced-vreg rep -- spill-slot )
126 rep-size spill-slots get [
127 nip cfg get stack-frame>>
128 [ align-spill-area ] [ next-spill-slot ] 2bi
131 : lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
132 rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
134 : init-allocator ( intervals/sync-points registers -- )
136 >unhandled-min-heap unhandled-min-heap set
137 [ V{ } clone ] reg-class-assoc active-intervals set
138 [ V{ } clone ] reg-class-assoc inactive-intervals set
139 V{ } clone handled-intervals set
140 H{ } clone spill-slots set
143 : add-use-position ( n reg assoc -- )
144 [ [ min ] when* ] change-at ;
146 : register-available? ( new result -- ? )
147 [ live-interval-end ] [ second ] bi* < ; inline
149 : register-available ( new result -- )
150 first >>reg add-active ;