1 #if __GLASGOW_HASKELL__ >= 611
2 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
4 -- Norman likes local bindings
5 -- If this module lives on I'd like to get rid of this flag in due course
9 , dualLiveLattice, dualLiveTransfers, dualLiveness
10 --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
11 , dualLivenessWithInsertion
16 , removeDeadAssignmentsAndReloads
32 import Outputable hiding (empty)
33 import qualified Outputable as PP
37 import Prelude hiding (zip)
39 {- Note [Overview of spill/reload]
40 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
41 The point of this module is to insert spills and reloads to
42 establish the invariant that at a call (or at any proc point with
43 an established protocol) all live variables not expected in
44 registers are sitting on the stack. We use a backward analysis to
45 insert spills and reloads. It should be followed by a
46 forward transformation to sink reloads as deeply as possible, so as
47 to reduce register pressure.
49 A variable can be expected to be live in a register, live on the
50 stack, or both. This analysis ensures that spills and reloads are
51 inserted as needed to make sure that every live variable needed
52 after a call is available on the stack. Spills are pushed back to
53 their reaching definitions, but reloads are dropped wherever needed
54 and will have to be sunk by a later forward transformation.
57 data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
59 dualUnion :: DualLive -> DualLive -> DualLive
60 dualUnion (DualLive s r) (DualLive s' r') =
61 DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
63 dualUnionList :: [DualLive] -> DualLive
64 dualUnionList ls = DualLive ss rs
65 where ss = unionManyUniqSets $ map on_stack ls
66 rs = unionManyUniqSets $ map in_regs ls
68 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
69 changeStack f live = live { on_stack = f (on_stack live) }
70 changeRegs f live = live { in_regs = f (in_regs live) }
73 dualLiveLattice :: DataflowLattice DualLive
75 DataflowLattice "variables live in registers and on stack" empty add False
76 where empty = DualLive emptyRegSet emptyRegSet
77 -- | compute in the Tx monad to track whether anything has changed
78 add new old = do stack <- add1 (on_stack new) (on_stack old)
79 regs <- add1 (in_regs new) (in_regs old)
80 return $ DualLive stack regs
81 add1 = fact_add_to liveLattice
83 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
85 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
86 dualLivenessWithInsertion procPoints g@(LGraph entry _) =
87 liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
88 where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
89 dualLiveLattice (dualLiveTransfers entry procPoints)
90 (insertSpillAndReloadRewrites entry procPoints) empty g
91 empty = fact_bot dualLiveLattice
93 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
94 dualLiveness procPoints g@(LGraph entry _) =
95 liftM zdfFpFacts $ (res :: LiveReloadFix ())
96 where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
97 (dualLiveTransfers entry procPoints) empty g
98 empty = fact_bot dualLiveLattice
100 dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
101 dualLiveTransfers entry procPoints = BackwardTransfers first middle last
102 where last = lastDualLiveness
103 middle = middleDualLiveness
104 first id live = check live id $ -- live at procPoint => spill
105 if id /= entry && elemBlockSet id procPoints then
106 DualLive { on_stack = on_stack live `plusRegSet` in_regs live
107 , in_regs = emptyRegSet }
109 check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
111 middleDualLiveness :: Middle -> DualLive -> DualLive
112 middleDualLiveness m live =
113 changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
114 where regs_in live = case m of MidForeignCall {} -> emptyRegSet
116 updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
117 spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
119 reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
121 check (RegSlot (LocalReg _ ty), o, w) x
122 | o == w && w == widthInBytes (typeWidth ty) = x
123 check _ _ = panic "middleDualLiveness unsupported: slices"
125 lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive
126 lastDualLiveness l env = last l
127 where last (LastBranch id) = env id
128 last l@(LastCall _ Nothing _ _ _) = changeRegs (gen l . kill l) empty
129 last l@(LastCall _ (Just k) _ _ _) =
130 -- nothing can be live in registers at this point, unless safe foreign call
132 live_in = DualLive (on_stack live) (gen l emptyRegSet)
133 in if isEmptyUniqSet (in_regs live) then live_in
134 else pprTrace "Offending party:" (ppr k <+> ppr live) $
135 panic "live values in registers at call continuation"
136 last l@(LastCondBranch _ t f) =
137 changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
138 last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ dualUnionList $
139 map env (catMaybes tbl)
140 empty = fact_bot dualLiveLattice
142 gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
143 gen a live = foldRegsUsed extendRegSet live a
144 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
145 kill a live = foldRegsDefd deleteFromRegSet live a
147 insertSpillAndReloadRewrites ::
148 BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
149 insertSpillAndReloadRewrites entry procPoints =
150 BackwardRewrites first middle last exit
151 where middle = middleInsertSpillsAndReloads
155 if id /= entry && elemBlockSet id procPoints then
156 case map reload (uniqSetToList (in_regs live)) of
158 is -> Just (mkMiddles is)
161 middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
162 middleInsertSpillsAndReloads m live = middle m
163 where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
164 | reg == reg' = Nothing
165 middle (MidAssign (CmmLocal reg) _) =
166 if reg `elemRegSet` on_stack live then -- must spill
167 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
168 text "after", ppr m]) $
169 Just $ mkMiddles $ [m, spill reg]
171 middle (MidForeignCall _ _ fs _) =
172 case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
173 map reload (uniqSetToList (kill fs (in_regs live))) of
175 reloads -> Just (mkMiddles (m : reloads))
178 -- Generating spill and reload code
179 regSlot :: LocalReg -> CmmExpr
180 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
182 spill, reload :: LocalReg -> Middle
183 spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
184 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
186 ----------------------------------------------------------------
189 -- The idea is to compute at each point the set of registers such that
190 -- on every path to the point, the register is defined by a Reload
191 -- instruction. Then, if a use appears at such a point, we can safely
192 -- insert a Reload right before the use. Finally, we can eliminate
193 -- the early reloads along with other dead assignments.
195 data AvailRegs = UniverseMinus RegSet
199 availRegsLattice :: DataflowLattice AvailRegs
200 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
201 where empty = UniverseMinus emptyRegSet
202 -- | compute in the Tx monad to track whether anything has changed
204 let join = interAvail new old in
205 if join `smallerAvail` old then aTx join else noTx join
208 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
209 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
210 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
211 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
212 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
214 smallerAvail :: AvailRegs -> AvailRegs -> Bool
215 smallerAvail (AvailRegs _) (UniverseMinus _) = True
216 smallerAvail (UniverseMinus _) (AvailRegs _) = False
217 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
218 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
220 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
221 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
222 extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
224 delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
225 delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
226 delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
228 elemAvail :: AvailRegs -> LocalReg -> Bool
229 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
230 elemAvail (AvailRegs s) r = elemRegSet r s
232 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
234 cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
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 (flip const) middleAvail lastAvail id
243 middleAvail :: Middle -> AvailRegs -> AvailRegs
244 middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
245 | l `isStackSlotOf` r = extendAvail avail r
246 middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
247 middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
248 | l `isStackSlotOf` r = avail
249 middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
250 middleAvail (MidStore {}) avail = avail
251 middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet
252 middleAvail (MidComment {}) avail = avail
254 lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
255 lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
256 lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
258 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
260 availRewrites :: ForwardRewrites Middle Last AvailRegs
261 availRewrites = ForwardRewrites first middle last exit
262 where first _ _ = Nothing
263 middle m avail = maybe_reload_before avail m (mkMiddle m)
264 last l avail = maybe_reload_before avail l (mkLast l)
266 maybe_reload_before avail node tail =
267 let used = filterRegsUsed (elemAvail avail) node
268 in if isEmptyUniqSet used then Nothing
269 else Just $ reloadTail used tail
270 reloadTail regset t = foldl rel t $ uniqSetToList regset
271 where rel t r = mkMiddle (reload r) <*> t
274 insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
275 insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
276 where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
277 availRegsLattice avail_reloads_transfer availRewrites bot g
278 bot = fact_bot availRegsLattice
280 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
281 removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
282 liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
283 where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
284 dualLiveLattice (dualLiveTransfers entry procPoints)
285 rewrites (fact_bot dualLiveLattice) g
286 rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
287 nothing _ _ = Nothing
289 middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
290 middleRemoveDeads (MidAssign (CmmLocal reg') _) live
291 | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
292 middleRemoveDeads _ _ = Nothing
296 ---------------------
299 ppr_regs :: String -> RegSet -> SDoc
300 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
301 where commafy xs = hsep $ punctuate comma xs
303 instance Outputable DualLive where
304 ppr (DualLive {in_regs = regs, on_stack = stack}) =
305 if isEmptyUniqSet regs && isEmptyUniqSet stack then
306 text "<nothing-live>"
308 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
309 else (ppr_regs "live in regs =" regs),
310 if isEmptyUniqSet stack then PP.empty
311 else (ppr_regs "live on stack =" stack)]
313 instance Outputable AvailRegs where
314 ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
315 else ppr_regs "available = all but" s
316 ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
317 else ppr_regs "available = " s
319 my_trace :: String -> SDoc -> a -> a
320 my_trace = if False then pprTrace else \_ _ a -> a
322 f4sep :: [SDoc] -> SDoc
324 f4sep (d:ds) = fsep (d : map (nest 4) ds)