5 , dualLiveLattice, dualLiveness
6 , insertSpillsAndReloads --- XXX todo check live-in at entry against formals
7 , dualLivenessWithInsertion
8 , spillAndReloadComments
14 , removeDeadAssignmentsAndReloads
30 import Outputable hiding (empty)
31 import qualified Outputable as PP
37 import Prelude hiding (zip)
39 -- The point of this module is to insert spills and reloads to
40 -- establish the invariant that at a call (or at any proc point with
41 -- an established protocol) all live variables not expected in
42 -- registers are sitting on the stack. We use a backward analysis to
43 -- insert spills and reloads. It should some day be followed by a
44 -- forward transformation to sink reloads as deeply as possible, so as
45 -- to reduce register pressure.
47 data ExtendWithSpills m
52 type M = ExtendWithSpills Middle
54 -- A variable can be expected to be live in a register, live on the
55 -- stack, or both. This analysis ensures that spills and reloads are
56 -- inserted as needed to make sure that every live variable needed
57 -- after a call is available on the stack. Spills are pushed back to
58 -- their reaching definitions, but reloads are dropped wherever needed
59 -- and will have to be sunk by a later forward transformation.
61 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
63 dualUnion :: DualLive -> DualLive -> DualLive
64 dualUnion (DualLive s r) (DualLive s' r') =
65 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
67 dualUnionList :: [DualLive] -> DualLive
68 dualUnionList ls = DualLive ss rs
69 where ss = unionManyUniqSets $ map on_stack ls
70 rs = unionManyUniqSets $ map in_regs ls
72 _changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
73 _changeStack f live = live { on_stack = f (on_stack live) }
74 changeRegs f live = live { in_regs = f (in_regs live) }
77 dualLiveLattice :: DataflowLattice DualLive
79 DataflowLattice "variables live in registers and on stack" empty add False
80 where empty = DualLive emptyRegSet emptyRegSet
81 -- | compute in the Tx monad to track whether anything has changed
82 add new old = do stack <- add1 (on_stack new) (on_stack old)
83 regs <- add1 (in_regs new) (in_regs old)
84 return $ DualLive stack regs
85 add1 = fact_add_to liveLattice
87 dualLivenessWithInsertion :: BPass M Last DualLive
88 dualLivenessWithInsertion = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
90 dualLiveness :: BAnalysis M Last DualLive
91 dualLiveness = BComp "dual liveness" exit last middle first
93 last = lastDualLiveness
94 middle = middleDualLiveness
96 empty = fact_bot dualLiveLattice
98 -- ^ could take a proc-point set and choose to spill here,
99 -- but it's probably better to run this pass, choose
100 -- proc-point protocols, insert more CopyIn nodes, and run
103 middleDualLiveness :: DualLive -> M -> DualLive
104 middleDualLiveness live (Spill regs) = live'
105 -- live-in on-stack requirements are satisfied;
106 -- live-out in-regs obligations are created
107 where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
108 , in_regs = in_regs live `plusRegSet` regs }
110 middleDualLiveness live (Reload regs) = live'
111 -- live-in in-regs requirements are satisfied;
112 -- live-out on-stack obligations are created
113 where live' = DualLive { on_stack = on_stack live `plusRegSet` regs
114 , in_regs = in_regs live `minusRegSet` regs }
116 middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
118 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
119 lastDualLiveness env l = last l
120 where last (LastReturn) = empty
121 last (LastJump e) = changeRegs (gen e) empty
122 last (LastBranch id) = env id
123 last (LastCall tgt Nothing) = changeRegs (gen tgt) empty
124 last (LastCall tgt (Just k)) =
125 -- nothing can be live in registers at this point
127 if isEmptyUniqSet (in_regs live) then
128 DualLive (on_stack live) (gen tgt emptyRegSet)
130 panic "live values in registers at call continuation"
131 last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
132 last (LastSwitch e tbl) = changeRegs (gen e) $ dualUnionList $
133 map env (catMaybes tbl)
134 empty = fact_bot dualLiveLattice
136 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
137 gen a live = foldRegsUsed extendRegSet live a
138 kill a live = foldRegsUsed delOneFromUniqSet live a
140 insertSpillsAndReloads :: BFunctionalTransformation M Last DualLive
141 insertSpillsAndReloads = BComp "CPS spiller" exit last middle first
143 last = \_ _ -> Nothing
144 middle = middleInsertSpillsAndReloads
146 -- ^ could take a proc-point set and choose to spill here,
147 -- but it's probably better to run this pass, choose
148 -- proc-point protocols, insert more CopyIn nodes, and run
152 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
153 middleInsertSpillsAndReloads _ (Spill _) = Nothing
154 middleInsertSpillsAndReloads _ (Reload _) = Nothing
155 middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
156 where middle (MidAssign (CmmLocal reg) _) =
157 if reg `elemRegSet` on_stack live then -- must spill
158 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
159 text "after", ppr m]) $
160 Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
163 middle (CopyIn _ formals _) =
164 -- only 'formals' can be in regs at this point
165 let regs' = kill formals (in_regs live) -- live in regs; must reload
166 is_stack_var r = elemRegSet r (on_stack live)
167 needs_spilling = filterRegsUsed is_stack_var formals
168 -- a formal that is expected on the stack; must spill
169 in if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
172 let code = if isEmptyUniqSet regs' then []
173 else Reload regs' : []
174 code' = if isEmptyUniqSet needs_spilling then code
175 else Spill needs_spilling : code
177 my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
178 ppr (Reload regs' :: M),
179 ppr (Spill needs_spilling :: M),
180 text "after", ppr m]) $
181 Just $ graphOfMiddles (m : code')
184 -- | For conversion back to vanilla C--
185 spillAndReloadComments :: M -> Middle
186 spillAndReloadComments (NotSpillOrReload m) = m
187 spillAndReloadComments (Spill regs) = show_regs "Spill" regs
188 spillAndReloadComments (Reload regs) = show_regs "Reload" regs
190 show_regs :: String -> RegSet -> Middle
191 show_regs s regs = MidComment $ mkFastString $ showSDoc $ ppr_regs s regs
194 ----------------------------------------------------------------
197 -- The idea is to compute at each point the set of registers such that
198 -- on every path to the point, the register is defined by a Reload
199 -- instruction. Then, if a use appears at such a point, we can safely
200 -- insert a Reload right before the use. Finally, we can eliminate
201 -- the early reloads along with other dead assignments.
203 data AvailRegs = UniverseMinus RegSet
207 availRegsLattice :: DataflowLattice AvailRegs
208 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
209 -- last True <==> debugging on
210 where empty = UniverseMinus emptyRegSet
211 -- | compute in the Tx monad to track whether anything has changed
213 let join = interAvail new old in
214 if join `smallerAvail` old then aTx join else noTx join
217 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
218 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
219 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
220 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
221 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
223 smallerAvail :: AvailRegs -> AvailRegs -> Bool
224 smallerAvail (AvailRegs _) (UniverseMinus _) = True
225 smallerAvail (UniverseMinus _) (AvailRegs _) = False
226 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
227 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
229 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
230 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
231 extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
233 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
234 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
235 deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
237 elemAvail :: AvailRegs -> LocalReg -> Bool
238 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
239 elemAvail (AvailRegs s) r = elemRegSet r s
241 cmmAvailableReloads :: LGraph M Last -> BlockEnv AvailRegs
242 cmmAvailableReloads g = env
243 where env = runDFA availRegsLattice $
244 do run_f_anal avail_reloads_transfer (fact_bot availRegsLattice) g
247 avail_reloads_transfer :: FAnalysis M Last AvailRegs
248 avail_reloads_transfer = FComp "available-reloads analysis" first middle last exit
249 where exit avail = avail
250 first avail _ = avail
251 middle = flip middleAvail
255 -- | The transfer equations use the traditional 'gen' and 'kill'
256 -- notations, which should be familiar from the dragon book.
257 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
258 agen a live = foldRegsUsed extendAvail live a
259 akill a live = foldRegsUsed deleteFromAvail live a
261 middleAvail :: M -> AvailRegs -> AvailRegs
262 middleAvail (Spill _) = id
263 middleAvail (Reload regs) = agen regs
264 middleAvail (NotSpillOrReload m) = middle m
265 where middle (MidComment {}) = id
266 middle (MidAssign lhs _expr) = akill lhs
267 middle (MidStore {}) = id
268 middle (MidUnsafeCall _tgt ress _args) = akill ress
269 middle (MidAddToContext {}) = id
270 middle (CopyIn _ formals _) = akill formals
271 middle (CopyOut {}) = id
273 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
274 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
275 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
277 insertLateReloads :: LGraph M Last -> FuelMonad (LGraph M Last)
278 insertLateReloads g = mapM_blocks insertM g
279 where env = cmmAvailableReloads g
280 avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
281 insertM b = fuelConsumingPass "late reloads" (insert b)
282 insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
283 propagate h avail (ZTail m t) fuel =
284 let (h', fuel') = maybe_add_reload h avail m fuel in
285 propagate (ZHead h' m) (middleAvail m avail) t fuel'
286 propagate h avail (ZLast l) fuel =
287 let (h', fuel') = maybe_add_reload h avail l fuel in
288 (zipht h' (ZLast l), fuel')
289 maybe_add_reload h avail node fuel =
290 let used = filterRegsUsed (elemAvail avail) node
291 in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used then (h,fuel)
292 else (ZHead h (Reload used), oneLessFuel fuel)
294 insertLateReloads' :: UniqSupply -> (Graph M Last) -> FuelMonad (Graph M Last)
295 insertLateReloads' us g =
296 runDFM us availRegsLattice $
297 f_shallow_rewrite avail_reloads_transfer insert bot g
298 where bot = fact_bot availRegsLattice
299 insert = null_f_ft { fc_middle_out = middle, fc_last_outs = last }
300 middle :: AvailRegs -> M -> Maybe (Graph M Last)
301 last :: AvailRegs -> Last -> Maybe (Graph M Last)
302 middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
303 last avail l = maybe_reload_before avail l (ZLast (LastOther l))
304 maybe_reload_before avail node tail =
305 let used = filterRegsUsed (elemAvail avail) node
306 in if isEmptyUniqSet used then Nothing
307 else Just $ graphOfZTail $ ZTail (Reload used) tail
309 _lateReloadsWithoutFuel :: LGraph M Last -> LGraph M Last
310 _lateReloadsWithoutFuel g = map_blocks insert g
311 where env = cmmAvailableReloads g
312 avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
313 insert (Block id tail) = propagate (ZFirst id) (avail id) tail
314 propagate h avail (ZTail m t) =
315 propagate (ZHead (maybe_add_reload h avail m) m) (middleAvail m avail) t
316 propagate h avail (ZLast l) =
317 zipht (maybe_add_reload h avail l) (ZLast l)
318 maybe_add_reload h avail node =
319 let used = filterRegsUsed (elemAvail avail) node
320 in if isEmptyUniqSet used then h
321 else ZHead h (Reload used)
324 removeDeadAssignmentsAndReloads :: BPass M Last DualLive
325 removeDeadAssignmentsAndReloads = a_ft_b dualLiveness remove_deads
326 where remove_deads = BComp "dead-assignment & -reload elim" exit last middle first
328 last = \_ _ -> Nothing
329 middle = middleRemoveDeads
332 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
333 middleRemoveDeads _ (Spill _) = Nothing
334 middleRemoveDeads live (Reload s) =
335 if sizeUniqSet worth_reloading < sizeUniqSet s then
336 Just $ if isEmptyUniqSet worth_reloading then emptyGraph
337 else graphOfMiddles [Reload worth_reloading]
340 where worth_reloading = intersectUniqSets s (in_regs live)
341 middleRemoveDeads live (NotSpillOrReload m) = middle m
342 where middle (MidAssign (CmmLocal reg') _)
343 | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
348 ---------------------
351 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
352 foldRegsUsed f z (Spill regs) = foldRegsUsed f z regs
353 foldRegsUsed _f z (Reload _) = z
354 foldRegsUsed f z (NotSpillOrReload m) = foldRegsUsed f z m
356 ---------------------
359 instance Outputable m => Outputable (ExtendWithSpills m) where
360 ppr (Spill regs) = ppr_regs "Spill" regs
361 ppr (Reload regs) = ppr_regs "Reload" regs
362 ppr (NotSpillOrReload m) = ppr m
364 instance Outputable m => DebugNodes (ExtendWithSpills m) Last
366 ppr_regs :: String -> RegSet -> SDoc
367 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
368 where commafy xs = hsep $ punctuate comma xs
370 instance Outputable DualLive where
371 ppr (DualLive {in_regs = regs, on_stack = stack}) =
372 if isEmptyUniqSet regs && isEmptyUniqSet stack then
373 text "<nothing-live>"
375 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
376 else (ppr_regs "live in regs =" regs),
377 if isEmptyUniqSet stack then PP.empty
378 else (ppr_regs "live on stack =" stack)]
380 instance Outputable AvailRegs where
381 ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
382 else ppr_regs "available = all but" s
383 ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
384 else ppr_regs "available = " s
386 my_trace :: String -> SDoc -> a -> a
387 my_trace = if False then pprTrace else \_ _ a -> a
389 f4sep :: [SDoc] -> SDoc
391 f4sep (d:ds) = fsep (d : map (nest 4) ds)