5 , dualLiveLattice, dualLiveTransfers, dualLiveness
6 --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
7 , dualLivenessWithInsertion
14 , removeDeadAssignmentsAndReloads
23 import OptimizationFuel
32 import Outputable hiding (empty)
33 import qualified Outputable as PP
38 import Prelude hiding (zip)
40 -- The point of this module is to insert spills and reloads to
41 -- establish the invariant that at a call (or at any proc point with
42 -- an established protocol) all live variables not expected in
43 -- registers are sitting on the stack. We use a backward analysis to
44 -- insert spills and reloads. It should some day be followed by a
45 -- forward transformation to sink reloads as deeply as possible, so as
46 -- to reduce register pressure.
48 data ExtendWithSpills m
53 type M = ExtendWithSpills Middle
55 -- A variable can be expected to be live in a register, live on the
56 -- stack, or both. This analysis ensures that spills and reloads are
57 -- inserted as needed to make sure that every live variable needed
58 -- after a call is available on the stack. Spills are pushed back to
59 -- their reaching definitions, but reloads are dropped wherever needed
60 -- and will have to be sunk by a later forward transformation.
62 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
64 dualUnion :: DualLive -> DualLive -> DualLive
65 dualUnion (DualLive s r) (DualLive s' r') =
66 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
68 dualUnionList :: [DualLive] -> DualLive
69 dualUnionList ls = DualLive ss rs
70 where ss = unionManyUniqSets $ map on_stack ls
71 rs = unionManyUniqSets $ map in_regs ls
73 _changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
74 _changeStack f live = live { on_stack = f (on_stack live) }
75 changeRegs f live = live { in_regs = f (in_regs live) }
78 dualLiveLattice :: DataflowLattice DualLive
80 DataflowLattice "variables live in registers and on stack" empty add True
81 where empty = DualLive emptyRegSet emptyRegSet
82 -- | compute in the Tx monad to track whether anything has changed
83 add new old = do stack <- add1 (on_stack new) (on_stack old)
84 regs <- add1 (in_regs new) (in_regs old)
85 return $ DualLive stack regs
86 add1 = fact_add_to liveLattice
88 type LiveReloadFix a = FuelMonad (BackwardFixedPoint M Last DualLive a)
90 dualLivenessWithInsertion :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
91 dualLivenessWithInsertion procPoints g =
92 liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
93 where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dual liveness with insertion"
94 dualLiveLattice (dualLiveTransfers procPoints)
95 (insertSpillAndReloadRewrites procPoints) empty g
96 empty = fact_bot dualLiveLattice
97 -- = a_ft_b_unlimited dualLiveness insertSpillsAndReloads
99 dualLiveness :: BlockSet -> Graph M Last -> FuelMonad (BlockEnv DualLive)
100 dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
101 where res = zdfSolveFrom emptyBlockEnv "dual liveness" dualLiveLattice
102 (dualLiveTransfers procPoints) empty g
103 empty = fact_bot dualLiveLattice
105 dualLiveTransfers :: BlockSet -> BackwardTransfers M Last DualLive
106 dualLiveTransfers procPoints = BackwardTransfers first middle last
107 where last = lastDualLiveness
108 middle = middleDualLiveness
110 if elemBlockSet _id procPoints then -- live at procPoint => spill
111 DualLive { on_stack = on_stack live `plusRegSet` in_regs live
112 , in_regs = emptyRegSet }
116 middleDualLiveness :: DualLive -> M -> DualLive
117 middleDualLiveness live (Spill regs) = live'
118 -- live-in on-stack requirements are satisfied;
119 -- live-out in-regs obligations are created
120 where live' = DualLive { on_stack = on_stack live `minusRegSet` regs
121 , in_regs = in_regs live `plusRegSet` regs }
123 middleDualLiveness live (Reload regs) = live'
124 -- live-in in-regs requirements are satisfied;
125 -- live-out on-stack obligations are created
126 where live' = DualLive { on_stack = on_stack live `plusRegSet` regs
127 , in_regs = in_regs live `minusRegSet` regs }
129 middleDualLiveness live (NotSpillOrReload m) = changeRegs (middleLiveness m) live
131 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
132 lastDualLiveness env l = last l
133 where last (LastReturn) = empty
134 last (LastJump e) = changeRegs (gen e) empty
135 last (LastBranch id) = env id
136 last (LastCall tgt Nothing) = changeRegs (gen tgt) empty
137 last (LastCall tgt (Just k)) =
138 -- nothing can be live in registers at this point
140 if isEmptyUniqSet (in_regs live) then
141 DualLive (on_stack live) (gen tgt emptyRegSet)
143 pprTrace "Offending party:" (ppr k <+> ppr live) $
144 panic "live values in registers at call continuation"
145 last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f)
146 last (LastSwitch e tbl) = changeRegs (gen e) $ dualUnionList $
147 map env (catMaybes tbl)
148 empty = fact_bot dualLiveLattice
150 gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
151 gen a live = foldRegsUsed extendRegSet live a
152 kill a live = foldRegsUsed delOneFromUniqSet live a
154 insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites M Last DualLive Graph
155 insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
156 where middle = middleInsertSpillsAndReloads
157 last = \_ _ -> Nothing
160 if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
161 Just $ graphOfMiddles $ [Reload reloads]
163 where reloads = in_regs live
166 middleInsertSpillsAndReloads :: DualLive -> M -> Maybe (Graph M Last)
167 middleInsertSpillsAndReloads _ (Spill _) = Nothing
168 middleInsertSpillsAndReloads _ (Reload _) = Nothing
169 middleInsertSpillsAndReloads live m@(NotSpillOrReload nsr) = middle nsr
170 where middle (MidAssign (CmmLocal reg) _) =
171 if reg `elemRegSet` on_stack live then -- must spill
172 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
173 text "after", ppr m]) $
174 Just $ graphOfMiddles [m, Spill $ mkRegSet [reg]]
177 middle (CopyIn _ formals _) =
178 -- only 'formals' can be in regs at this point
179 let regs' = kill formals (in_regs live) -- live in regs; must reload
180 is_stack_var r = elemRegSet r (on_stack live)
181 needs_spilling = filterRegsUsed is_stack_var formals
182 -- a formal that is expected on the stack; must spill
183 in if isEmptyUniqSet regs' && isEmptyUniqSet needs_spilling then
186 let code = if isEmptyUniqSet regs' then []
187 else Reload regs' : []
188 code' = if isEmptyUniqSet needs_spilling then code
189 else Spill needs_spilling : code
191 my_trace "At CopyIn" (f4sep [text "Triggered by ", ppr live,
192 ppr (Reload regs' :: M),
193 ppr (Spill needs_spilling :: M),
194 text "after", ppr m]) $
195 Just $ graphOfMiddles (m : code')
198 -- | For conversion back to vanilla C--
200 elimSpillAndReload :: StackSlotMap -> LGraph M l -> FuelMonad (StackSlotMap, LGraph Middle l)
201 elimSpillAndReload slots g = fold_blocks block (return (slots, [])) g >>= toGraph
202 where toGraph (slots, l) = return (slots, of_block_list (lg_entry g) l)
203 block (Block id t) z =
204 do (slots, blocks) <- z
205 (slots, t) <- tail t slots
206 return (slots, Block id t : blocks)
207 tail (ZLast l) slots = return (slots, ZLast l)
208 tail (ZTail m t) slots =
209 do (slots, t) <- tail t slots
211 middle (Spill regs) t slots = foldUniqSet spill (return (slots, t)) regs
212 middle (Reload regs) t slots = foldUniqSet reload (return (slots, t)) regs
213 middle (NotSpillOrReload m) t slots = return (slots, ZTail m t)
214 move f r z = do let reg = CmmLocal r
216 (slots, slot) <- getSlot slots reg
217 return (slots, ZTail (f (CmmStack slot) reg) t)
218 spill = move (\ slot reg -> MidAssign slot (CmmReg reg))
219 reload = move (\ slot reg -> MidAssign reg (CmmReg slot))
222 ----------------------------------------------------------------
225 -- The idea is to compute at each point the set of registers such that
226 -- on every path to the point, the register is defined by a Reload
227 -- instruction. Then, if a use appears at such a point, we can safely
228 -- insert a Reload right before the use. Finally, we can eliminate
229 -- the early reloads along with other dead assignments.
231 data AvailRegs = UniverseMinus RegSet
235 availRegsLattice :: DataflowLattice AvailRegs
236 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
237 -- last True <==> debugging on
238 where empty = UniverseMinus emptyRegSet
239 -- | compute in the Tx monad to track whether anything has changed
241 let join = interAvail new old in
242 if join `smallerAvail` old then aTx join else noTx join
245 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
246 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
247 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
248 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
249 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
251 smallerAvail :: AvailRegs -> AvailRegs -> Bool
252 smallerAvail (AvailRegs _) (UniverseMinus _) = True
253 smallerAvail (UniverseMinus _) (AvailRegs _) = False
254 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
255 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
257 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
258 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
259 extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
261 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
262 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
263 deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
265 elemAvail :: AvailRegs -> LocalReg -> Bool
266 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
267 elemAvail (AvailRegs s) r = elemRegSet r s
269 type CmmAvail = BlockEnv AvailRegs
270 type AvailFix = FuelMonad (ForwardFixedPoint M Last AvailRegs ())
272 cmmAvailableReloads :: Graph M Last -> FuelMonad CmmAvail
273 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
274 where res = zdfSolveFrom emptyBlockEnv "available reloads" availRegsLattice
275 avail_reloads_transfer empty g
276 empty = (fact_bot availRegsLattice)
278 avail_reloads_transfer :: ForwardTransfers M Last AvailRegs
279 avail_reloads_transfer = ForwardTransfers first middle last id
280 where first avail _ = avail
281 middle = flip middleAvail
284 -- | The transfer equations use the traditional 'gen' and 'kill'
285 -- notations, which should be familiar from the dragon book.
286 agen, akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
287 agen a live = foldRegsUsed extendAvail live a
288 akill a live = foldRegsUsed deleteFromAvail live a
290 -- Note: you can't sink the reload past a use.
291 middleAvail :: M -> AvailRegs -> AvailRegs
292 middleAvail (Spill _) = id
293 middleAvail (Reload regs) = agen regs
294 middleAvail (NotSpillOrReload m) = middle m
295 where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
296 middle' (MidComment {}) = id
297 middle' (MidAssign lhs _expr) = akill lhs
298 middle' (MidStore {}) = id
299 middle' (MidUnsafeCall _tgt ress _args) = akill ress
300 middle' (MidAddToContext {}) = id
301 middle' (CopyIn _ formals _) = akill formals
302 middle' (CopyOut {}) = id
304 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
305 lastAvail _ (LastCall _ (Just k)) = LastOutFacts [(k, AvailRegs emptyRegSet)]
306 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
308 insertLateReloads :: Graph M Last -> FuelMonad (Graph M Last)
309 insertLateReloads g =
310 do env <- cmmAvailableReloads g
312 liftM graphOfLGraph $ mapM_blocks (insertM env) g
313 where insertM env b = fuelConsumingPass "late reloads" (insert b)
314 where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
315 insert (Block id tail) fuel = propagate (ZFirst id) (avail id) tail fuel
316 propagate h avail (ZTail m t) fuel =
317 let (h', fuel') = maybe_add_reload h avail m fuel in
318 propagate (ZHead h' m) (middleAvail m avail) t fuel'
319 propagate h avail (ZLast l) fuel =
320 let (h', fuel') = maybe_add_reload h avail l fuel in
321 (zipht h' (ZLast l), fuel')
322 maybe_add_reload h avail node fuel =
323 let used = filterRegsUsed (elemAvail avail) node
324 in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
326 else (ZHead h (Reload used), oneLessFuel fuel)
328 type LateReloadFix = FuelMonad (ForwardFixedPoint M Last AvailRegs (Graph M Last))
330 insertLateReloads' :: (Graph M Last) -> FuelMonad (Graph M Last)
331 insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
332 where res = zdfRewriteFrom RewriteShallow emptyBlockEnv "insert late reloads"
333 availRegsLattice avail_reloads_transfer rewrites bot g
334 bot = fact_bot availRegsLattice
335 rewrites = ForwardRewrites first middle last exit
337 middle :: AvailRegs -> M -> Maybe (Graph M Last)
338 last :: AvailRegs -> Last -> Maybe (Graph M Last)
339 middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
340 last avail l = maybe_reload_before avail l (ZLast (LastOther l))
342 maybe_reload_before avail node tail =
343 let used = filterRegsUsed (elemAvail avail) node
344 in if isEmptyUniqSet used then Nothing
345 else Just $ graphOfZTail $ ZTail (Reload used) tail
347 removeDeadAssignmentsAndReloads :: BlockSet -> (Graph M Last) -> FuelMonad (Graph M Last)
348 removeDeadAssignmentsAndReloads procPoints g =
349 liftM zdfFpContents $ (res :: LiveReloadFix (Graph M Last))
350 where res = zdfRewriteFrom RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
351 dualLiveLattice (dualLiveTransfers procPoints)
352 rewrites (fact_bot dualLiveLattice) g
353 rewrites = BackwardRewrites first middle last exit
355 last = \_ _ -> Nothing
356 middle = middleRemoveDeads
359 middleRemoveDeads :: DualLive -> M -> Maybe (Graph M Last)
360 middleRemoveDeads _ (Spill _) = Nothing
361 middleRemoveDeads live (Reload s) =
362 if sizeUniqSet worth_reloading < sizeUniqSet s then
363 Just $ if isEmptyUniqSet worth_reloading then emptyGraph
364 else graphOfMiddles [Reload worth_reloading]
367 where worth_reloading = intersectUniqSets s (in_regs live)
368 middleRemoveDeads live (NotSpillOrReload m) = middle m
369 where middle (MidAssign (CmmLocal reg') _)
370 | not (reg' `elemRegSet` in_regs live) = Just emptyGraph
375 ---------------------
378 instance UserOfLocalRegs m => UserOfLocalRegs (ExtendWithSpills m) where
379 foldRegsUsed f z (Spill regs) = foldRegsUsed f z regs
380 foldRegsUsed _f z (Reload _) = z
381 foldRegsUsed f z (NotSpillOrReload m) = foldRegsUsed f z m
383 ---------------------
386 instance Outputable m => Outputable (ExtendWithSpills m) where
387 ppr (Spill regs) = ppr_regs "Spill" regs
388 ppr (Reload regs) = ppr_regs "Reload" regs
389 ppr (NotSpillOrReload m) = ppr m
391 instance Outputable m => DebugNodes (ExtendWithSpills m) Last
393 ppr_regs :: String -> RegSet -> SDoc
394 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
395 where commafy xs = hsep $ punctuate comma xs
397 instance Outputable DualLive where
398 ppr (DualLive {in_regs = regs, on_stack = stack}) =
399 if isEmptyUniqSet regs && isEmptyUniqSet stack then
400 text "<nothing-live>"
402 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
403 else (ppr_regs "live in regs =" regs),
404 if isEmptyUniqSet stack then PP.empty
405 else (ppr_regs "live on stack =" stack)]
407 instance Outputable AvailRegs where
408 ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
409 else ppr_regs "available = all but" s
410 ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
411 else ppr_regs "available = " s
413 my_trace :: String -> SDoc -> a -> a
414 my_trace = if False then pprTrace else \_ _ a -> a
416 f4sep :: [SDoc] -> SDoc
418 f4sep (d:ds) = fsep (d : map (nest 4) ds)