4 , dualLiveLattice, dualLiveTransfers, dualLiveness
5 --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
6 , dualLivenessWithInsertion
12 , removeDeadAssignmentsAndReloads
22 import OptimizationFuel
30 import Outputable hiding (empty)
31 import qualified Outputable as PP
36 import Prelude hiding (zip)
38 -- The point of this module is to insert spills and reloads to
39 -- establish the invariant that at a call (or at any proc point with
40 -- an established protocol) all live variables not expected in
41 -- registers are sitting on the stack. We use a backward analysis to
42 -- insert spills and reloads. It should be followed by a
43 -- forward transformation to sink reloads as deeply as possible, so as
44 -- to reduce register pressure.
46 -- A variable can be expected to be live in a register, live on the
47 -- stack, or both. This analysis ensures that spills and reloads are
48 -- inserted as needed to make sure that every live variable needed
49 -- after a call is available on the stack. Spills are pushed back to
50 -- their reaching definitions, but reloads are dropped wherever needed
51 -- and will have to be sunk by a later forward transformation.
53 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
55 dualUnion :: DualLive -> DualLive -> DualLive
56 dualUnion (DualLive s r) (DualLive s' r') =
57 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
59 dualUnionList :: [DualLive] -> DualLive
60 dualUnionList ls = DualLive ss rs
61 where ss = unionManyUniqSets $ map on_stack ls
62 rs = unionManyUniqSets $ map in_regs ls
64 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
65 changeStack f live = live { on_stack = f (on_stack live) }
66 changeRegs f live = live { in_regs = f (in_regs live) }
69 dualLiveLattice :: DataflowLattice DualLive
71 DataflowLattice "variables live in registers and on stack" empty add True
72 where empty = DualLive emptyRegSet emptyRegSet
73 -- | compute in the Tx monad to track whether anything has changed
74 add new old = do stack <- add1 (on_stack new) (on_stack old)
75 regs <- add1 (in_regs new) (in_regs old)
76 return $ DualLive stack regs
77 add1 = fact_add_to liveLattice
79 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
81 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
82 dualLivenessWithInsertion procPoints g =
83 liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
84 where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
85 dualLiveLattice (dualLiveTransfers procPoints)
86 (insertSpillAndReloadRewrites procPoints) empty g
87 empty = fact_bot dualLiveLattice
89 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
90 dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
91 where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
92 (dualLiveTransfers procPoints) empty g
93 empty = fact_bot dualLiveLattice
95 dualLiveTransfers :: BlockSet -> BackwardTransfers Middle Last DualLive
96 dualLiveTransfers procPoints = BackwardTransfers first middle last
97 where last = lastDualLiveness
98 middle = middleDualLiveness
100 if elemBlockSet _id procPoints then -- live at procPoint => spill
101 DualLive { on_stack = on_stack live `plusRegSet` in_regs live
102 , in_regs = emptyRegSet }
105 middleDualLiveness :: DualLive -> Middle -> DualLive
106 middleDualLiveness live m =
107 changeStack updSlots $ changeRegs (middleLiveness m) live
108 where updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
109 spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
111 reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
113 check (RegSlot (LocalReg _ ty), o, w) x
114 | o == w && w == widthInBytes (typeWidth ty) = x
115 check _ _ = panic "middleDualLiveness unsupported: slices"
117 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
118 lastDualLiveness env l = last l
119 where last (LastReturn _) = empty
120 last (LastJump e _) = changeRegs (gen e) empty
121 last (LastBranch id) = env id
122 last (LastCall tgt Nothing _) = changeRegs (gen tgt) empty
123 last (LastCall tgt (Just k) _) =
124 -- nothing can be live in registers at this point
126 if isEmptyUniqSet (in_regs live) then
127 DualLive (on_stack live) (gen tgt emptyRegSet)
129 pprTrace "Offending party:" (ppr k <+> ppr live) $
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 :: UserOfLocalRegs a => a -> RegSet -> RegSet
137 gen a live = foldRegsUsed extendRegSet live a
139 insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites Middle Last DualLive
140 insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
141 where middle = middleInsertSpillsAndReloads
142 last = \_ _ -> Nothing
145 if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
146 Just $ mkMiddles $ map reload $ uniqSetToList reloads
148 where reloads = in_regs live
151 middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
152 middleInsertSpillsAndReloads live m = middle m
153 where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
154 | reg == reg' = Nothing
155 middle (MidAssign (CmmLocal reg) _) =
156 if reg `elemRegSet` on_stack live then -- must spill
157 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
158 text "after", ppr m]) $
159 Just $ mkMiddles $ [m, spill reg]
163 -- Generating spill and reload code
164 regSlot :: LocalReg -> CmmExpr
165 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
167 spill, reload :: LocalReg -> Middle
168 spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
169 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
171 spillHead :: ZHead Middle -> RegSet -> ZHead Middle
172 reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last
173 spillHead h regset = foldl spl h $ uniqSetToList regset
174 where spl h r = ZHead h $ spill r
175 reloadTail regset t = foldl rel t $ uniqSetToList regset
176 where rel t r = ZTail (reload r) t
178 ----------------------------------------------------------------
181 -- The idea is to compute at each point the set of registers such that
182 -- on every path to the point, the register is defined by a Reload
183 -- instruction. Then, if a use appears at such a point, we can safely
184 -- insert a Reload right before the use. Finally, we can eliminate
185 -- the early reloads along with other dead assignments.
187 data AvailRegs = UniverseMinus RegSet
191 availRegsLattice :: DataflowLattice AvailRegs
192 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
193 -- last True <==> debugging on
194 where empty = UniverseMinus emptyRegSet
195 -- | compute in the Tx monad to track whether anything has changed
197 let join = interAvail new old in
198 if join `smallerAvail` old then aTx join else noTx join
201 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
202 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
203 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
204 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
205 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
207 smallerAvail :: AvailRegs -> AvailRegs -> Bool
208 smallerAvail (AvailRegs _) (UniverseMinus _) = True
209 smallerAvail (UniverseMinus _) (AvailRegs _) = False
210 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
211 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
213 --extendAvail :: AvailRegs -> LocalReg -> AvailRegs
214 --extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
215 --extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
217 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
218 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
219 deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
221 elemAvail :: AvailRegs -> LocalReg -> Bool
222 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
223 elemAvail (AvailRegs s) r = elemRegSet r s
225 type CmmAvail = BlockEnv AvailRegs
226 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
228 cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
229 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
230 where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
231 avail_reloads_transfer empty g
232 empty = (fact_bot availRegsLattice)
234 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
235 avail_reloads_transfer = ForwardTransfers first middle last id
236 where first avail _ = avail
237 middle = flip middleAvail
240 -- | The transfer equations use the traditional 'gen' and 'kill'
241 -- notations, which should be familiar from the dragon book.
243 akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
244 --agen a live = foldRegsUsed extendAvail live a
245 akill a live = foldRegsUsed deleteFromAvail live a
247 -- Note: you can't sink the reload past a use.
248 middleAvail :: Middle -> AvailRegs -> AvailRegs
249 middleAvail m = middle m
250 where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
251 middle' (MidComment {}) = id
252 middle' (MidAssign lhs _expr) = akill lhs
253 middle' (MidStore {}) = id
254 middle' (MidUnsafeCall _tgt ress _args) = akill ress
255 middle' (MidAddToContext {}) = id
257 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
258 lastAvail _ (LastCall _ (Just k) _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
259 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
261 insertLateReloads :: LGraph Middle Last -> FuelMonad (LGraph Middle Last)
262 insertLateReloads g =
263 do env <- cmmAvailableReloads g
264 mapM_blocks (insertM env) g
265 where insertM env b = fuelConsumingPass "late reloads" (insert b)
266 where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
267 insert (Block id off tail) fuel =
268 propagate (ZFirst id off) (avail id) tail fuel
269 propagate h avail (ZTail m t) fuel =
270 let (h', fuel') = maybe_add_reload h avail m fuel in
271 propagate (ZHead h' m) (middleAvail m avail) t fuel'
272 propagate h avail (ZLast l) fuel =
273 let (h', fuel') = maybe_add_reload h avail l fuel in
274 (zipht h' (ZLast l), fuel')
275 maybe_add_reload h avail node fuel =
276 let used = filterRegsUsed (elemAvail avail) node
277 in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
279 else (spillHead h used, oneLessFuel fuel)
281 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs (LGraph Middle Last))
283 insertLateReloads' :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
284 insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
285 where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
286 availRegsLattice avail_reloads_transfer rewrites bot g
287 bot = fact_bot availRegsLattice
288 rewrites = ForwardRewrites first middle last exit
290 middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
291 last :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
292 middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
293 last avail l = maybe_reload_before avail l (ZLast (LastOther l))
295 maybe_reload_before avail node tail =
296 let used = filterRegsUsed (elemAvail avail) node
297 in if isEmptyUniqSet used then Nothing
298 else Just $ mkZTail $ reloadTail used tail
300 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
301 removeDeadAssignmentsAndReloads procPoints g =
302 liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
303 where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
304 dualLiveLattice (dualLiveTransfers procPoints)
305 rewrites (fact_bot dualLiveLattice) g
306 rewrites = BackwardRewrites first middle last exit
308 last = \_ _ -> Nothing
309 middle = middleRemoveDeads
312 middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
313 middleRemoveDeads live m = middle m
314 where middle (MidAssign (CmmLocal reg') _)
315 | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
320 ---------------------
323 ppr_regs :: String -> RegSet -> SDoc
324 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
325 where commafy xs = hsep $ punctuate comma xs
327 instance Outputable DualLive where
328 ppr (DualLive {in_regs = regs, on_stack = stack}) =
329 if isEmptyUniqSet regs && isEmptyUniqSet stack then
330 text "<nothing-live>"
332 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
333 else (ppr_regs "live in regs =" regs),
334 if isEmptyUniqSet stack then PP.empty
335 else (ppr_regs "live on stack =" stack)]
337 instance Outputable AvailRegs where
338 ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
339 else ppr_regs "available = all but" s
340 ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
341 else ppr_regs "available = " s
343 my_trace :: String -> SDoc -> a -> a
344 my_trace = if False then pprTrace else \_ _ a -> a
346 f4sep :: [SDoc] -> SDoc
348 f4sep (d:ds) = fsep (d : map (nest 4) ds)