2 ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
3 , layout, manifestSP, igraph, areaBuilder
4 , stubSlotsOnDeath ) -- to help crash early during debugging
8 import qualified Prelude as P
9 import Prelude hiding (zip, unzip, last)
19 import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
27 ------------------------------------------------------------------------
29 ------------------------------------------------------------------------
31 -- | Before we lay out the stack, we need to know something about the
32 -- liveness of the stack slots. In particular, to decide whether we can
33 -- reuse a stack location to hold multiple stack slots, we need to know
34 -- when each of the stack slots is used.
35 -- Although tempted to use something simpler, we really need a full interference
36 -- graph. Consider the following case:
38 -- 1 -> <spill x>; // y is dead out
39 -- 2 -> <spill y>; // x is dead out
40 -- 3 -> <spill x and y>
41 -- If we consider the arms in order and we use just the deadness information given by a
42 -- dataflow analysis, we might decide to allocate the stack slots for x and y
43 -- to the same stack location, which will lead to incorrect code in the third arm.
44 -- We won't make this mistake with an interference graph.
46 -- First, the liveness analysis.
47 -- We represent a slot with an area, an offset into the area, and a width.
48 -- Tracking the live slots is a bit tricky because there may be loads and stores
49 -- into only a part of a stack slot (e.g. loading the low word of a 2-word long),
50 -- e.g. Slot A 0 8 overlaps with Slot A 4 4.
52 -- The definition of a slot set is intended to reduce the number of overlap
53 -- checks we have to make. There's no reason to check for overlap between
54 -- slots in different areas, so we segregate the map by Area's.
55 -- We expect few slots in each Area, so we collect them in an unordered list.
56 -- To keep these lists short, any contiguous live slots are coalesced into
57 -- a single slot, on insertion.
59 slotLattice :: DataflowLattice SubAreaSet
60 slotLattice = DataflowLattice "live slots" emptyFM add True
61 where add new old = case foldFM addArea (False, old) new of
64 addArea a newSlots z = foldr (addSlot a) z newSlots
65 addSlot a slot (changed, map) =
66 let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a
67 in (c || changed, addToFM map a live)
69 type SlotEnv = BlockEnv SubAreaSet
70 type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a)
72 liveSlotAnal :: LGraph Middle Last -> FuelMonad SlotEnv
73 liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ())
74 where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice
75 liveSlotTransfers (fact_bot slotLattice) g
77 -- Add the subarea s to the subareas in the list-set (possibly coalescing it with
78 -- adjacent subareas), and also return whether s was a new addition.
79 liveGen :: SubArea -> [SubArea] -> (Bool, [SubArea])
80 liveGen s set = liveGen' s set []
81 where liveGen' s [] z = (True, s : z)
82 liveGen' s@(a, hi, w) (s'@(a', hi', w') : rst) z =
83 if a /= a' || hi < lo' || lo > hi' then -- no overlap
84 liveGen' s rst (s' : z)
85 else if s' `contains` s then -- old contains new
87 else -- overlap: coalesce the slots
88 let new_hi = max hi hi'
90 in liveGen' (a, new_hi, new_hi - new_lo) rst z
91 where lo = hi - w -- remember: areas grow down
93 contains (a, hi, w) (a', hi', w') =
94 a == a' && hi >= hi' && hi - w <= hi' - w'
96 liveKill :: SubArea -> [SubArea] -> [SubArea]
97 liveKill (a, hi, w) set = pprTrace "killing slots in area" (ppr a) $ liveKill' set []
98 where liveKill' [] z = z
99 liveKill' (s'@(a', hi', w') : rst) z =
100 if a /= a' || hi < lo' || lo > hi' then -- no overlap
101 liveKill' rst (s' : z)
102 else -- overlap: split the old slot
103 let z' = if hi' > hi then (a, hi', hi' - hi) : z else z
104 z'' = if lo > lo' then (a, lo, lo - lo') : z' else z'
106 where lo = hi - w -- remember: areas grow down
109 -- Note: the stack slots that hold variables returned on the stack are not
110 -- considered live in to the block -- we treat the first node as a definition site.
111 -- BEWARE?: Am I being a little careless here in failing to check for the
112 -- entry Id (which would use the CallArea Old).
113 liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
115 BackwardTransfers first liveInSlots liveLastIn
116 where first live id = delFromFM live (CallArea (Young id))
118 -- Slot sets: adding slots, removing slots, and checking for membership.
119 liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet
120 addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet
121 elemSlot :: SubAreaSet -> SubArea -> Bool
122 liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a)
123 addSlot live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live
124 removeSlot live (a, i, w) = liftToArea a (liveKill (a, i, w)) live
125 elemSlot live (a, i, w) =
126 not $ fst $ liveGen (a, i, w) (lookupWithDefaultFM live [] a)
128 removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
129 removeLiveSlotDefs = foldSlotsDefd removeSlot
131 liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
132 liveInSlots live x = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
134 liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
135 liveLastIn env l = liveInSlots (liveLastOut env l) l
137 -- Don't forget to keep the outgoing parameters in the CallArea live,
138 -- as well as the update frame.
139 -- Note: We have to keep the update frame live at a call because of the
140 -- case where the function doesn't return -- in that case, there won't
141 -- be a return to keep the update frame live. We'd still better keep the
142 -- info pointer in the update frame live at any call site;
143 -- otherwise we could screw up the garbage collector.
144 liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
147 LastCall _ Nothing n _ ->
148 add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
149 LastCall _ (Just k) n (Just upd_n) ->
150 add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
151 LastCall _ (Just k) n Nothing ->
152 add_area (CallArea (Young k)) n out
154 where out = joinOuts slotLattice env l
155 add_area _ n live | n == 0 = live
157 addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a
159 -- The liveness analysis must be precise: otherwise, we won't know if a definition
160 -- should really kill a live-out stack slot.
161 -- But the interference graph does not have to be precise -- it might decide that
162 -- any live areas interfere. To maintain both a precise analysis and an imprecise
163 -- interference graph, we need to convert the live-out stack slots to graph nodes
164 -- at each and every instruction; rather than reconstruct a new list of nodes
165 -- every time, I provide a function to fold over the nodes, which should be a
166 -- reasonably efficient approach for the implementations we envision.
167 -- Of course, it will probably be much easier to program if we just return a list...
168 type Set x = FiniteMap x ()
169 data IGraphBuilder n =
170 Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z
171 , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
174 areaBuilder :: IGraphBuilder Area
175 areaBuilder = Builder fold words
176 where fold (a, _, _) f z = f a z
177 words areaSize areaMap a =
178 case lookupFM areaMap a of
179 Just addr -> [addr .. addr + (lookupFM areaSize a `orElse`
180 pprPanic "wordsOccupied: unknown area" (ppr a))]
183 --slotBuilder :: IGraphBuilder (Area, Int)
184 --slotBuilder = undefined
186 -- Now, we can build the interference graph.
187 -- The usual story: a definition interferes with all live outs and all other
189 type IGraph x = FiniteMap x (Set x)
190 type IGPair x = (IGraph x, IGraphBuilder x)
191 igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x
192 igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
193 where foldN = foldNodes builder
194 interfere block igraph =
195 let (h, l) = goto_end (unzip block)
196 --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
197 heads (ZFirst _ _) (igraph, _) = igraph
198 heads (ZHead h m) (igraph, liveOut) =
199 heads h (addEdges igraph m liveOut, liveInSlots liveOut m)
200 -- add edges between a def and the other defs and liveouts
201 addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
202 addDef (igraph, out) def@(a, _, _) =
203 (foldN def (addDefN out) igraph,
204 addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a)))
205 addDefN out n igraph =
206 let addEdgeNO o igraph = foldN o addEdgeNN igraph
207 addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
208 addEdgeNN' n n' igraph = addToFM igraph n (addToFM set n' ())
209 where set = lookupWithDefaultFM igraph emptyFM n
210 in foldFM (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
211 env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
212 in heads h $ case l of LastExit -> (igraph, emptyFM)
213 LastOther l -> (addEdges igraph l $ liveLastOut env' l,
216 -- Before allocating stack slots, we need to collect one more piece of information:
217 -- what's the highest offset (in bytes) used in each Area?
218 -- We'll need to allocate that much space for each Area.
219 getAreaSize :: LGraph Middle Last -> AreaMap
220 getAreaSize g@(LGraph _ off _) =
221 fold_blocks (fold_fwd_block first add_regslots last)
222 (unitFM (CallArea Old) off) g
223 where first id (StackInfo {argBytes = Just off}) z = add z (CallArea (Young id)) off
225 add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
226 last l@(LastOther (LastCall _ Nothing off _)) z =
227 add_regslots l (add z (CallArea Old) off)
228 last l@(LastOther (LastCall _ (Just k) off _)) z =
229 add_regslots l (add z (CallArea (Young k)) off)
230 last l z = add_regslots l z
231 addSlot z (a@(RegSlot _), off, _) = add z a off
233 add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a))
236 -- Find the Stack slots occupied by the subarea's conflicts
237 conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
238 conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
239 foldNodes subarea foldNode emptyFM
240 where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n
241 conflict n' () set = liveInSlots areaMap n' set
242 -- Add stack slots occupied by igraph node n
243 liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
244 setAdd w s = addToFM s w ()
246 -- Find any open space on the stack, starting from the offset.
247 -- If the area is a CallArea or a spill slot for a pointer, then it must
249 freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
250 freeSlotFrom ig areaSize offset areaMap area =
251 let size = lookupFM areaSize area `orElse` 0
252 conflicts = conflictSlots ig areaSize areaMap (area, size, size)
253 -- CallAreas and Ptrs need to be word-aligned (round up!)
254 align = case area of CallArea _ -> align'
255 RegSlot r | isGcPtrType (localRegType r) -> align'
257 align' n = (n + (wORD_SIZE - 1)) `div` wORD_SIZE * wORD_SIZE
258 -- Find a space big enough to hold the area
259 findSpace curr 0 = curr
260 findSpace curr cnt = -- part of target slot, # of bytes left to check
261 if elemFM curr conflicts then
262 findSpace (align (curr + size)) size -- try the next (possibly) open space
263 else findSpace (curr - 1) (cnt - 1)
264 in findSpace (align (offset + size)) size
266 -- Find an open space on the stack, and assign it to the area.
267 allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
268 allocSlotFrom ig areaSize from areaMap area =
269 if elemFM area areaMap then areaMap
270 else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area
272 -- | Greedy stack layout.
273 -- Compute liveness, build the interference graph, and allocate slots for the areas.
274 -- We visit each basic block in a (generally) forward order.
275 -- At each instruction that names a register subarea r, we immediately allocate
276 -- any available slot on the stack by the following procedure:
277 -- 1. Find the nodes N' that conflict with r
278 -- 2. Find the stack slots used for N'
279 -- 3. Choose a contiguous stack space s not in N' (s must be large enough to hold r)
280 -- For a CallArea, we allocate the stack space only when we reach a function
281 -- call that returns to the CallArea's blockId.
282 -- We use a similar procedure, with one exception: the stack space
283 -- must be allocated below the youngest stack slot that is live out.
285 -- Note: The stack pointer only has to be younger than the youngest live stack slot
286 -- at proc points. Otherwise, the stack pointer can point anywhere.
287 layout :: ProcPointSet -> SlotEnv -> LGraph Middle Last -> AreaMap
288 layout procPoints env g@(LGraph _ entrySp _) =
289 let builder = areaBuilder
290 ig = (igraph builder env g, builder)
291 env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
292 areaSize = getAreaSize g
293 -- Find the slots that are live-in to the block
294 live_in (ZTail m l) = liveInSlots (live_in l) m
295 live_in (ZLast (LastOther l)) = liveLastIn env' l
296 live_in (ZLast LastExit) = emptyFM
297 -- Find the youngest live stack slot
298 youngest_live areaMap live = fold_subareas young_slot live 0
299 where young_slot (a, o, _) z = case lookupFM areaMap a of
300 Just top -> max z $ top + o
302 fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z
303 fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
304 -- Allocate space for spill slots and call areas
305 allocVarSlot = allocSlotFrom ig areaSize 0
306 allocCallSlot areaMap (Block id stackInfo t)
307 | elemBlockSet id procPoints =
308 let young = youngest_live areaMap $ live_in t
309 start = case returnOff stackInfo of Just b -> max b young
311 z = allocSlotFrom ig areaSize start areaMap (CallArea (Young id))
312 in pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z) z
313 allocCallSlot areaMap _ = areaMap
314 -- mid foreign calls need to have info tables placed on the stack
315 allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
316 let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
317 area = CallArea (Young bid)
318 areaSize' = addToFM areaSize area (widthInBytes (typeWidth gcWord))
319 in allocSlotFrom ig areaSize' young areaMap area
320 allocMidCall _ _ areaMap = areaMap
322 foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m
323 where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
324 alloc' areaMap _ = areaMap
325 layoutAreas areaMap b@(Block _ _ t) = layout areaMap t
326 where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
327 layout areaMap (ZLast _) = allocCallSlot areaMap b
328 areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) (postorder_dfs g)
329 in pprTrace "ProcPoints" (ppr procPoints) $
330 pprTrace "Area SizeMap" (ppr areaSize) $
331 pprTrace "Entry SP" (ppr entrySp) $
332 pprTrace "Area Map" (ppr areaMap) $ areaMap
334 -- After determining the stack layout, we can:
335 -- 1. Replace references to stack Areas with addresses relative to the stack
337 -- 2. Insert adjustments to the stack pointer to ensure that it is at a
338 -- conventional location at each proc point.
339 -- Because we don't take interrupts on the execution stack, we only need the
340 -- stack pointer to be younger than the live values on the stack at proc points.
341 -- 3. Compute the maximum stack offset used in the procedure and replace
342 -- the stack high-water mark with that offset.
343 manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap ->
344 LGraph Middle Last -> FuelMonad (LGraph Middle Last)
345 manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
346 liftM (LGraph entry args) blocks'
347 where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g)
348 slot a = pprTrace "slot" (ppr a) $
349 lookupFM areaMap a `orElse` panic "unallocated Area"
350 slot' (Just id) = slot $ CallArea (Young id)
351 slot' Nothing = slot $ CallArea Old
352 sp_high = maxSlot slot g
353 proc_entry_sp = slot (CallArea Old) + args
354 sp_on_entry id | id == entry = proc_entry_sp
356 case lookupBlockEnv blocks id of
357 Just (Block _ (StackInfo {argBytes = Just o}) _) -> slot' (Just id) + o
359 case expectJust "sp_on_entry" (lookupBlockEnv procMap id) of
361 case blockSetToList pp of
362 [id] -> sp_on_entry id
363 _ -> panic "block not reached by one proc point"
364 ProcPoint -> pprPanic "procpoint doesn't take any arguments?"
365 (ppr id <+> ppr g <+> ppr procPoints <+> ppr procMap)
367 -- On entry to procpoints, the stack pointer is conventional;
368 -- otherwise, we check the SP set by predecessors.
369 replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
370 replB blocks (Block id o t) =
371 do bs <- replTail (Block id o) spIn t
372 pprTrace "spIn" (ppr id <+> ppr spIn)$
373 liftM (flip (foldr insertBlock) bs) blocks
374 where spIn = sp_on_entry id
375 replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
376 FuelMonad ([CmmBlock])
377 replTail h spOff (ZTail m@(MidForeignCall (Safe bid _) _ _ _) t) =
378 replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
379 where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
380 replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
381 replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l
382 replTail h _ l@(ZLast LastExit) = return [h l]
383 middle spOff m = mapExpDeepMiddle (replSlot spOff) m
384 last spOff l = mapExpDeepLast (replSlot spOff) l
385 replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
386 replSlot spOff (CmmLit CmmHighStackMark) = -- replacing the high water mark
387 CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
389 -- The block must establish the SP expected at each successsor.
390 fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
391 fixSp h spOff l@(LastCall _ k n _) = updSp h spOff (slot' k + n) l
392 fixSp h spOff l@(LastBranch k) =
393 let succSp = sp_on_entry k in
394 if succSp /= spOff then
395 pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
396 updSp h spOff succSp l
397 else return $ [h (ZLast (LastOther (last spOff l)))]
398 fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
399 where b = h (ZLast (LastOther (last spOff l)))
401 let succSp = sp_on_entry succId in
402 if succSp /= spOff then
404 (b', bs') <- insertBetween b [setSpMid spOff succSp] succId
405 return (b', bs ++ bs')
407 updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)]
408 setSpMid sp sp' = MidAssign (CmmGlobal Sp) e
409 where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
410 off = CmmLit $ CmmInt (toInteger $ sp - sp') wordWidth
411 setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t
414 -- To compute the stack high-water mark, we fold over the graph and
415 -- compute the highest slot offset.
416 maxSlot :: (Area -> Int) -> CmmGraph -> Int
417 maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g
418 where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
419 add z (a, i, w) = max z (slotOff a + i)
421 -----------------------------------------------------------------------------
422 -- | Sanity check: stub pointers immediately after they die
423 -----------------------------------------------------------------------------
424 -- This will miss stack slots that are last used in a Last node,
425 -- but it should do pretty well...
427 type StubPtrFix = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet CmmGraph)
429 stubSlotsOnDeath :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
430 stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix)
431 where res = zdfBRewriteFromL RewriteShallow emptyBlockEnv "stub ptrs" slotLattice
432 liveSlotTransfers rewrites (fact_bot slotLattice) g
433 rewrites = BackwardRewrites first middle last Nothing
436 middle liveSlots m = foldSlotsUsed (stub liveSlots m) Nothing m
437 stub liveSlots m rst subarea@(a, off, w) =
438 if elemSlot liveSlots subarea then rst
439 else let store = mkStore (CmmStackSlot a off)
440 (stackStubExpr (widthFromBytes w))
441 in case rst of Nothing -> Just (mkMiddle m <*> store)
442 Just g -> Just (g <*> store)