4 , dualLiveLattice, dualLiveTransfers, dualLiveness
5 --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
6 , dualLivenessWithInsertion
11 , removeDeadAssignmentsAndReloads
21 import OptimizationFuel
28 import Outputable hiding (empty)
29 import qualified Outputable as PP
34 import Prelude hiding (zip)
36 -- The point of this module is to insert spills and reloads to
37 -- establish the invariant that at a call (or at any proc point with
38 -- an established protocol) all live variables not expected in
39 -- registers are sitting on the stack. We use a backward analysis to
40 -- insert spills and reloads. It should be followed by a
41 -- forward transformation to sink reloads as deeply as possible, so as
42 -- to reduce register pressure.
44 -- A variable can be expected to be live in a register, live on the
45 -- stack, or both. This analysis ensures that spills and reloads are
46 -- inserted as needed to make sure that every live variable needed
47 -- after a call is available on the stack. Spills are pushed back to
48 -- their reaching definitions, but reloads are dropped wherever needed
49 -- and will have to be sunk by a later forward transformation.
51 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
53 dualUnion :: DualLive -> DualLive -> DualLive
54 dualUnion (DualLive s r) (DualLive s' r') =
55 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
57 dualUnionList :: [DualLive] -> DualLive
58 dualUnionList ls = DualLive ss rs
59 where ss = unionManyUniqSets $ map on_stack ls
60 rs = unionManyUniqSets $ map in_regs ls
62 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
63 changeStack f live = live { on_stack = f (on_stack live) }
64 changeRegs f live = live { in_regs = f (in_regs live) }
67 dualLiveLattice :: DataflowLattice DualLive
69 DataflowLattice "variables live in registers and on stack" empty add False
70 where empty = DualLive emptyRegSet emptyRegSet
71 -- | compute in the Tx monad to track whether anything has changed
72 add new old = do stack <- add1 (on_stack new) (on_stack old)
73 regs <- add1 (in_regs new) (in_regs old)
74 return $ DualLive stack regs
75 add1 = fact_add_to liveLattice
77 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
79 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
80 dualLivenessWithInsertion procPoints g@(LGraph entry _ _) =
81 liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
82 where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
83 dualLiveLattice (dualLiveTransfers entry procPoints)
84 (insertSpillAndReloadRewrites entry procPoints) empty g
85 empty = fact_bot dualLiveLattice
87 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
88 dualLiveness procPoints g@(LGraph entry _ _) =
89 liftM zdfFpFacts $ (res :: LiveReloadFix ())
90 where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
91 (dualLiveTransfers entry procPoints) empty g
92 empty = fact_bot dualLiveLattice
94 dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
95 dualLiveTransfers entry procPoints = BackwardTransfers first middle last
96 where last = lastDualLiveness
97 middle = middleDualLiveness
98 first live id = check live id $ -- live at procPoint => spill
99 if id /= entry && elemBlockSet id procPoints then
100 DualLive { on_stack = on_stack live `plusRegSet` in_regs live
101 , in_regs = emptyRegSet }
103 check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
105 middleDualLiveness :: DualLive -> Middle -> DualLive
106 middleDualLiveness live m =
107 changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
108 where regs_in live = case m of MidForeignCall {} -> emptyRegSet
110 updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
111 spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
113 reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
115 check (RegSlot (LocalReg _ ty), o, w) x
116 | o == w && w == widthInBytes (typeWidth ty) = x
117 check _ _ = panic "middleDualLiveness unsupported: slices"
119 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
120 lastDualLiveness env l = last l
121 where last (LastBranch id) = env id
122 last l@(LastCall _ Nothing _ _) = changeRegs (gen l . kill l) empty
123 last l@(LastCall _ (Just k) _ _) =
124 -- nothing can be live in registers at this point, unless safe foreign call
126 live_in = DualLive (on_stack live) (gen l emptyRegSet)
127 in if isEmptyUniqSet (in_regs live) then live_in
128 else pprTrace "Offending party:" (ppr k <+> ppr live) $
129 panic "live values in registers at call continuation"
130 last l@(LastCondBranch _ t f) =
131 changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
132 last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ 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
138 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
139 kill a live = foldRegsDefd deleteFromRegSet live a
141 insertSpillAndReloadRewrites ::
142 BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
143 insertSpillAndReloadRewrites entry procPoints =
144 BackwardRewrites first middle last exit
145 where middle = middleInsertSpillsAndReloads
149 if id /= entry && elemBlockSet id procPoints then
150 case map reload (uniqSetToList (in_regs live)) of
152 is -> Just (mkMiddles is)
155 middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
156 middleInsertSpillsAndReloads live m = middle m
157 where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
158 | reg == reg' = Nothing
159 middle (MidAssign (CmmLocal reg) _) =
160 if reg `elemRegSet` on_stack live then -- must spill
161 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
162 text "after", ppr m]) $
163 Just $ mkMiddles $ [m, spill reg]
165 middle (MidForeignCall _ _ fs _) =
166 case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
167 map reload (uniqSetToList (kill fs (in_regs live))) of
169 reloads -> Just (mkMiddles (m : reloads))
172 -- Generating spill and reload code
173 regSlot :: LocalReg -> CmmExpr
174 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
176 spill, reload :: LocalReg -> Middle
177 spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
178 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
180 reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last
181 reloadTail regset t = foldl rel t $ uniqSetToList regset
182 where rel t r = ZTail (reload r) t
184 ----------------------------------------------------------------
187 -- The idea is to compute at each point the set of registers such that
188 -- on every path to the point, the register is defined by a Reload
189 -- instruction. Then, if a use appears at such a point, we can safely
190 -- insert a Reload right before the use. Finally, we can eliminate
191 -- the early reloads along with other dead assignments.
193 data AvailRegs = UniverseMinus RegSet
197 availRegsLattice :: DataflowLattice AvailRegs
198 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
199 -- last True <==> debugging on
200 where empty = UniverseMinus emptyRegSet
201 -- | compute in the Tx monad to track whether anything has changed
203 let join = interAvail new old in
204 if join `smallerAvail` old then aTx join else noTx join
207 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
208 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
209 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
210 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
211 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
213 smallerAvail :: AvailRegs -> AvailRegs -> Bool
214 smallerAvail (AvailRegs _) (UniverseMinus _) = True
215 smallerAvail (UniverseMinus _) (AvailRegs _) = False
216 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
217 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
219 --extendAvail :: AvailRegs -> LocalReg -> AvailRegs
220 --extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
221 --extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
223 deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
224 deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
225 deleteFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
227 elemAvail :: AvailRegs -> LocalReg -> Bool
228 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
229 elemAvail (AvailRegs s) r = elemRegSet r s
231 type CmmAvail = BlockEnv AvailRegs
232 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
234 cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
235 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
236 where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
237 avail_reloads_transfer empty g
238 empty = fact_bot availRegsLattice
240 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
241 avail_reloads_transfer = ForwardTransfers first middle last id
242 where first avail _ = avail
243 middle = flip middleAvail
246 -- | The transfer equations use the traditional 'gen' and 'kill'
247 -- notations, which should be familiar from the dragon book.
249 akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
250 --agen a live = foldRegsUsed extendAvail live a
251 akill a live = foldRegsUsed deleteFromAvail live a
253 -- Note: you can't sink the reload past a use.
254 middleAvail :: Middle -> AvailRegs -> AvailRegs
255 middleAvail m = middle m
256 where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
257 middle' (MidComment {}) live = live
258 middle' (MidAssign lhs _expr) live = akill lhs live
259 middle' (MidStore {}) live = live
260 middle' (MidForeignCall {}) _ = AvailRegs emptyRegSet
262 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
263 lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
264 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
266 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
268 insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
269 insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
270 where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
271 availRegsLattice avail_reloads_transfer rewrites bot g
272 bot = fact_bot availRegsLattice
273 rewrites = ForwardRewrites first middle last exit
275 middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
276 last :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
277 middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
278 last avail l = maybe_reload_before avail l (ZLast (LastOther l))
280 maybe_reload_before avail node tail =
281 let used = filterRegsUsed (elemAvail avail) node
282 in if isEmptyUniqSet used then Nothing
283 else Just $ mkZTail $ reloadTail used tail
285 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
286 removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) =
287 liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
288 where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
289 dualLiveLattice (dualLiveTransfers entry procPoints)
290 rewrites (fact_bot dualLiveLattice) g
291 rewrites = BackwardRewrites first middle last exit
293 last = \_ _ -> Nothing
294 middle = middleRemoveDeads
297 middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
298 middleRemoveDeads live m = middle m
299 where middle (MidAssign (CmmLocal reg') _)
300 | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
305 ---------------------
308 ppr_regs :: String -> RegSet -> SDoc
309 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
310 where commafy xs = hsep $ punctuate comma xs
312 instance Outputable DualLive where
313 ppr (DualLive {in_regs = regs, on_stack = stack}) =
314 if isEmptyUniqSet regs && isEmptyUniqSet stack then
315 text "<nothing-live>"
317 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
318 else (ppr_regs "live in regs =" regs),
319 if isEmptyUniqSet stack then PP.empty
320 else (ppr_regs "live on stack =" stack)]
322 instance Outputable AvailRegs where
323 ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
324 else ppr_regs "available = all but" s
325 ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
326 else ppr_regs "available = " s
328 my_trace :: String -> SDoc -> a -> a
329 my_trace = if False then pprTrace else \_ _ a -> a
331 f4sep :: [SDoc] -> SDoc
333 f4sep (d:ds) = fsep (d : map (nest 4) ds)