1 {-# LANGUAGE GADTs,NoMonoLocalBinds #-}
2 -- Norman likes local bindings
3 -- If this module lives on I'd like to get rid of this flag in due course
5 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
6 #if __GLASGOW_HASKELL__ >= 701
7 -- GHC 7.0.1 improved incomplete pattern warnings with GADTs
8 {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
13 , dualLiveLattice, dualLiveTransfers, dualLiveness
14 --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
15 , dualLivenessWithInsertion
20 , removeDeadAssignmentsAndReloads
28 import OptimizationFuel
31 import Outputable hiding (empty)
32 import qualified Outputable as PP
37 import Prelude hiding (succ, 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
74 dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
75 where empty = DualLive emptyRegSet emptyRegSet
76 add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
77 where (change1, stack) = add1 (on_stack old) (on_stack new)
78 (change2, regs) = add1 (in_regs old) (in_regs new)
79 add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
80 where join = unionUniqSets old new
82 dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
83 dualLivenessWithInsertion procPoints g =
84 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
85 (dualLiveTransfers (g_entry g) procPoints)
86 (insertSpillAndReloadRewrites g procPoints)
88 dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
89 dualLiveness procPoints g =
90 liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
92 dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
93 dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
94 where first :: CmmNode C O -> DualLive -> DualLive
95 first (CmmEntry id) live = check live id $ -- live at procPoint => spill
96 if id /= entry && setMember id procPoints
97 then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
98 , in_regs = emptyRegSet }
100 where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
102 middle :: CmmNode O O -> DualLive -> DualLive
103 middle m = changeStack updSlots
105 where -- Reuse middle of liveness analysis from CmmLive
106 updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m
108 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"
116 last :: CmmNode O C -> FactBase DualLive -> DualLive
117 last l fb = case l of
118 CmmBranch id -> lkp id
119 l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
120 l@(CmmCall {cml_cont=Just k}) -> call l k
121 l@(CmmForeignCall {succ=k}) -> call l k
122 l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
123 l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
124 where empty = fact_bot dualLiveLattice
125 lkp id = empty `fromMaybe` lookupFact id fb
126 call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
128 gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
129 gen a live = foldRegsUsed extendRegSet live a
130 kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
131 kill a live = foldRegsDefd deleteFromRegSet live a
133 insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
134 insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
135 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
136 -- but GHC miscompiles it, see bug #4044.
137 where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
138 first e@(CmmEntry id) live = return $
139 if id /= (g_entry graph) && setMember id procPoints then
140 case map reload (uniqSetToList spill_regs) of
142 is -> Just $ mkFirst e <*> mkMiddles is
145 -- If we are splitting procedures, we need the LastForeignCall
146 -- to spill its results to the stack because they will only
147 -- be used by a separate procedure (so they can't stay in LocalRegs).
149 spill_regs = if splitting then in_regs live
150 else in_regs live `minusRegSet` defs
151 defs = case mapLookup id firstDefs of
153 Nothing -> emptyRegSet
154 -- A LastForeignCall may contain some definitions, which take place
155 -- on return from the function call. Therefore, we build a map (firstDefs)
156 -- from BlockId to the set of variables defined on return to the BlockId.
157 firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
158 addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
159 addLive b env = case lastNode b of
160 CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
162 add bid defs env = mapInsert bid defs'' env
163 where defs'' = case mapLookup bid env of
164 Just defs' -> timesRegSet defs defs'
167 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
168 middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
169 middle m@(CmmAssign (CmmLocal reg) _) live = return $
170 if reg `elemRegSet` on_stack live then -- must spill
171 my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
172 text "after"{-, ppr m-}]) $
173 Just $ mkMiddles $ [m, spill reg]
175 middle m@(CmmUnsafeForeignCall _ fs _) live = return $
176 case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
177 map reload (uniqSetToList (kill fs (in_regs live))) of
179 reloads -> Just $ mkMiddles (m : reloads)
180 middle _ _ = return Nothing
182 nothing _ _ = return Nothing
184 regSlot :: LocalReg -> CmmExpr
185 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
187 spill, reload :: LocalReg -> CmmNode O O
188 spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
189 reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
191 ----------------------------------------------------------------
194 -- The idea is to compute at each point the set of registers such that
195 -- on every path to the point, the register is defined by a Reload
196 -- instruction. Then, if a use appears at such a point, we can safely
197 -- insert a Reload right before the use. Finally, we can eliminate
198 -- the early reloads along with other dead assignments.
200 data AvailRegs = UniverseMinus RegSet
204 availRegsLattice :: DataflowLattice AvailRegs
205 availRegsLattice = DataflowLattice "register gotten from reloads" empty add
206 where empty = UniverseMinus emptyRegSet
207 -- | compute in the Tx monad to track whether anything has changed
208 add _ (OldFact old) (NewFact new) =
209 if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
210 where join = interAvail new old
213 interAvail :: AvailRegs -> AvailRegs -> AvailRegs
214 interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
215 interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
216 interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
217 interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
219 smallerAvail :: AvailRegs -> AvailRegs -> Bool
220 smallerAvail (AvailRegs _) (UniverseMinus _) = True
221 smallerAvail (UniverseMinus _) (AvailRegs _) = False
222 smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
223 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
225 extendAvail :: AvailRegs -> LocalReg -> AvailRegs
226 extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
227 extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
229 delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
230 delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
231 delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
233 elemAvail :: AvailRegs -> LocalReg -> Bool
234 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
235 elemAvail (AvailRegs s) r = elemRegSet r s
237 cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
238 cmmAvailableReloads g =
239 liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
240 analFwd availRegsLattice availReloadsTransfer
242 availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
243 availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
245 middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
246 middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
247 | l `isStackSlotOf` r = extendAvail avail r
248 middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
249 middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
250 | l `isStackSlotOf` r = avail
251 middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
252 middleAvail (CmmStore {}) avail = avail
253 middleAvail (CmmUnsafeForeignCall {}) _ = AvailRegs emptyRegSet
254 middleAvail (CmmComment {}) avail = avail
256 lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
257 lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
258 lastAvail (CmmForeignCall {succ=k}) _ = [(k, AvailRegs emptyRegSet)]
259 lastAvail l avail = map (\id -> (id, avail)) $ successors l
261 insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
262 insertLateReloads g =
263 liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
264 analRewFwd availRegsLattice availReloadsTransfer rewrites
265 where rewrites = mkFRewrite3 first middle last
266 first _ _ = return Nothing
267 middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
268 last l avail = return $ maybe_reload_before avail l (mkLast l)
269 maybe_reload_before avail node tail =
270 let used = filterRegsUsed (elemAvail avail) node
271 in if isEmptyUniqSet used then Nothing
272 else Just $ reloadTail used tail
273 reloadTail regset t = foldl rel t $ uniqSetToList regset
274 where rel t r = mkMiddle (reload r) <*> t
276 removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
277 removeDeadAssignmentsAndReloads procPoints g =
278 liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
279 (dualLiveTransfers (g_entry g) procPoints)
281 where rewrites = deepBwdRw3 nothing middle nothing
282 -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
283 -- but GHC panics while compiling, see bug #4045.
284 middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
285 middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
286 middle _ _ = return Nothing
288 nothing _ _ = return Nothing
291 ---------------------
294 ppr_regs :: String -> RegSet -> SDoc
295 ppr_regs s regs = text s <+> commafy (map ppr $ uniqSetToList regs)
296 where commafy xs = hsep $ punctuate comma xs
298 instance Outputable DualLive where
299 ppr (DualLive {in_regs = regs, on_stack = stack}) =
300 if isEmptyUniqSet regs && isEmptyUniqSet stack then
301 text "<nothing-live>"
303 nest 2 $ fsep [if isEmptyUniqSet regs then PP.empty
304 else (ppr_regs "live in regs =" regs),
305 if isEmptyUniqSet stack then PP.empty
306 else (ppr_regs "live on stack =" stack)]
308 instance Outputable AvailRegs where
309 ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
310 else ppr_regs "available = all but" s
311 ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
312 else ppr_regs "available = " s
314 my_trace :: String -> SDoc -> a -> a
315 my_trace = if False then pprTrace else \_ _ a -> a
317 f4sep :: [SDoc] -> SDoc
319 f4sep (d:ds) = fsep (d : map (nest 4) ds)