compiler/cmm/CmmStackLayout.hs

   1 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
   2 -- Norman likes local bindings
   3 -- If this module lives on I'd like to get rid of this flag in due course
   4
   5 module CmmStackLayout
   6     ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
   7     , layout, manifestSP, igraph, areaBuilder
   8     , stubSlotsOnDeath ) -- to help crash early during debugging
   9 where
  10
  11 import Constants
  12 import Prelude hiding (zip, unzip, last)
  13
  14 import BlockId
  15 import CmmExpr
  16 import CmmProcPointZ
  17 import CmmTx
  18 import DFMonad
  19 import Maybes
  20 import MkZipCfg
  21 import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
  22 import Control.Monad
  23 import Outputable
  24 import SMRep (ByteOff)
  25 import ZipCfg
  26 import ZipCfg as Z
  27 import ZipCfgCmmRep
  28 import ZipDataflow
  29
  30 import Data.Map (Map)
  31 import qualified Data.Map as Map
  32 import qualified FiniteMap as Map
  33
  34 ------------------------------------------------------------------------
  35 --                    Stack Layout                                    --
  36 ------------------------------------------------------------------------
  37
  38 -- | Before we lay out the stack, we need to know something about the
  39 -- liveness of the stack slots. In particular, to decide whether we can
  40 -- reuse a stack location to hold multiple stack slots, we need to know
  41 -- when each of the stack slots is used.
  42 -- Although tempted to use something simpler, we really need a full interference
  43 -- graph. Consider the following case:
  44 --   case <...> of
  45 --     1 -> <spill x>; // y is dead out
  46 --     2 -> <spill y>; // x is dead out
  47 --     3 -> <spill x and y>
  48 -- If we consider the arms in order and we use just the deadness information given by a
  49 -- dataflow analysis, we might decide to allocate the stack slots for x and y
  50 -- to the same stack location, which will lead to incorrect code in the third arm.
  51 -- We won't make this mistake with an interference graph.
  52
  53 -- First, the liveness analysis.
  54 -- We represent a slot with an area, an offset into the area, and a width.
  55 -- Tracking the live slots is a bit tricky because there may be loads and stores
  56 -- into only a part of a stack slot (e.g. loading the low word of a 2-word long),
  57 -- e.g. Slot A 0 8 overlaps with Slot A 4 4.
  58 --
  59 -- The definition of a slot set is intended to reduce the number of overlap
  60 -- checks we have to make. There's no reason to check for overlap between
  61 -- slots in different areas, so we segregate the map by Area's.
  62 -- We expect few slots in each Area, so we collect them in an unordered list.
  63 -- To keep these lists short, any contiguous live slots are coalesced into
  64 -- a single slot, on insertion.
  65
  66 slotLattice :: DataflowLattice SubAreaSet
  67 slotLattice = DataflowLattice "live slots" Map.empty add False
  68   where add new old = case Map.foldRightWithKey addArea (False, old) new of
  69                         (True,  x) -> aTx  x
  70                         (False, x) -> noTx x
  71         addArea a newSlots z = foldr (addSlot a) z newSlots
  72         addSlot a slot (changed, map) =
  73           let (c, live) = liveGen slot $ Map.findWithDefault [] a map
  74           in (c || changed, Map.insert a live map)
  75
  76 type SlotEnv   = BlockEnv SubAreaSet
  77   -- The sub-areas live on entry to the block
  78
  79 type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a)
  80
  81 liveSlotAnal :: LGraph Middle Last -> FuelMonad SlotEnv
  82 liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ())
  83   where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice
  84                             liveSlotTransfers (fact_bot slotLattice) g
  85
  86 -- Add the subarea s to the subareas in the list-set (possibly coalescing it with
  87 -- adjacent subareas), and also return whether s was a new addition.
  88 liveGen :: SubArea -> [SubArea] -> (Bool, [SubArea])
  89 liveGen s set = liveGen' s set []
  90   where liveGen' s [] z = (True, s : z)
  91         liveGen' s@(a, hi, w) (s'@(a', hi', w') : rst) z =
  92           if a /= a' || hi < lo' || lo > hi' then    -- no overlap
  93             liveGen' s rst (s' : z)
  94           else if s' `contains` s then               -- old contains new
  95             (False, set)
  96           else                                       -- overlap: coalesce the slots
  97             let new_hi = max hi hi'
  98                 new_lo = min lo lo'
  99             in liveGen' (a, new_hi, new_hi - new_lo) rst z
 100           where lo  = hi  - w  -- remember: areas grow down
 101                 lo' = hi' - w'
 102         contains (a, hi, w) (a', hi', w') =
 103           a == a' && hi >= hi' && hi - w <= hi' - w'
 104
 105 liveKill :: SubArea -> [SubArea] -> [SubArea]
 106 liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $
 107                           liveKill' set []
 108   where liveKill' [] z = z
 109         liveKill' (s'@(a', hi', w') : rst) z =
 110           if a /= a' || hi < lo' || lo > hi' then    -- no overlap
 111             liveKill' rst (s' : z)
 112           else                                       -- overlap: split the old slot
 113             let z'  = if hi' > hi  then (a, hi', hi' - hi)  : z else z
 114                 z'' = if lo  > lo' then (a, lo,  lo  - lo') : z' else z'
 115             in liveKill' rst z''
 116           where lo  = hi  - w  -- remember: areas grow down
 117                 lo' = hi' - w'
 118
 119 -- Note: the stack slots that hold variables returned on the stack are not
 120 -- considered live in to the block -- we treat the first node as a definition site.
 121 -- BEWARE?: Am I being a little careless here in failing to check for the
 122 -- entry Id (which would use the CallArea Old).
 123 liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
 124 liveSlotTransfers =
 125   BackwardTransfers first liveInSlots liveLastIn
 126     where first id live = Map.delete (CallArea (Young id)) live
 127
 128 -- Slot sets: adding slots, removing slots, and checking for membership.
 129 liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet
 130 addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet
 131 elemSlot            :: SubAreaSet -> SubArea -> Bool
 132 liftToArea a f map = Map.insert a (f (Map.findWithDefault [] a map)) map
 133 addSlot    live (a, i, w) = liftToArea a (snd . liveGen  (a, i, w)) live
 134 removeSlot live (a, i, w) = liftToArea a       (liveKill (a, i, w)) live
 135 elemSlot   live (a, i, w) =
 136   not $ fst $ liveGen  (a, i, w) (Map.findWithDefault [] a live)
 137
 138 removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
 139 removeLiveSlotDefs = foldSlotsDefd removeSlot
 140
 141 liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet
 142 liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
 143
 144 liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet
 145 liveLastIn l env = liveInSlots l (liveLastOut env l)
 146
 147 -- Don't forget to keep the outgoing parameters in the CallArea live,
 148 -- as well as the update frame.
 149 -- Note: We have to keep the update frame live at a call because of the
 150 -- case where the function doesn't return -- in that case, there won't
 151 -- be a return to keep the update frame live. We'd still better keep the
 152 -- info pointer in the update frame live at any call site;
 153 -- otherwise we could screw up the garbage collector.
 154 liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
 155 liveLastOut env l =
 156   case l of
 157     LastCall _ Nothing n _ _ ->
 158       add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
 159     LastCall _ (Just k) n _ (Just _) ->
 160       add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
 161     LastCall _ (Just k) n _ Nothing ->
 162       add_area (CallArea (Young k)) n out
 163     _ -> out
 164   where out = joinOuts slotLattice env l
 165         add_area _ n live | n == 0 = live
 166         add_area a n live =
 167           Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live
 168
 169 -- The liveness analysis must be precise: otherwise, we won't know if a definition
 170 -- should really kill a live-out stack slot.
 171 -- But the interference graph does not have to be precise -- it might decide that
 172 -- any live areas interfere. To maintain both a precise analysis and an imprecise
 173 -- interference graph, we need to convert the live-out stack slots to graph nodes
 174 -- at each and every instruction; rather than reconstruct a new list of nodes
 175 -- every time, I provide a function to fold over the nodes, which should be a
 176 -- reasonably efficient approach for the implementations we envision.
 177 -- Of course, it will probably be much easier to program if we just return a list...
 178 type Set x = Map x ()
 179 data IGraphBuilder n =
 180   Builder { foldNodes     :: forall z. SubArea -> (n -> z -> z) -> z -> z
 181           , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
 182           }
 183
 184 areaBuilder :: IGraphBuilder Area
 185 areaBuilder = Builder fold words
 186   where fold (a, _, _) f z = f a z
 187         words areaSize areaMap a =
 188           case Map.lookup a areaMap of
 189             Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse`
 190                                           pprPanic "wordsOccupied: unknown area" (ppr a))]
 191             Nothing   -> []
 192
 193 --slotBuilder :: IGraphBuilder (Area, Int)
 194 --slotBuilder = undefined
 195
 196 -- Now, we can build the interference graph.
 197 -- The usual story: a definition interferes with all live outs and all other
 198 -- definitions.
 199 type IGraph x = Map x (Set x)
 200 type IGPair x = (IGraph x, IGraphBuilder x)
 201 igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x
 202 igraph builder env g = foldr interfere Map.empty (postorder_dfs g)
 203   where foldN = foldNodes builder
 204         interfere block igraph =
 205           let (h, l) = goto_end (unzip block)
 206               --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
 207               heads (ZFirst _) (igraph, _)       = igraph
 208               heads (ZHead h m)    (igraph, liveOut) =
 209                 heads h (addEdges igraph m liveOut, liveInSlots m liveOut)
 210               -- add edges between a def and the other defs and liveouts
 211               addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
 212               addDef (igraph, out) def@(a, _, _) =
 213                 (foldN def (addDefN out) igraph,
 214                  Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out)
 215               addDefN out n igraph =
 216                 let addEdgeNO o igraph = foldN o addEdgeNN igraph
 217                     addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
 218                     addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph
 219                       where set = Map.findWithDefault Map.empty n igraph
 220                 in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
 221               env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
 222           in heads h $ case l of LastExit    -> (igraph, Map.empty)
 223                                  LastOther l -> (addEdges igraph l $ liveLastOut env' l,
 224                                                  liveLastIn l env')
 225
 226 -- Before allocating stack slots, we need to collect one more piece of information:
 227 -- what's the highest offset (in bytes) used in each Area?
 228 -- We'll need to allocate that much space for each Area.
 229 getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap
 230   -- The domain of the returned mapping consists only of Areas
 231   -- used for (a) variable spill slots, and (b) parameter passing ares for calls
 232 getAreaSize entry_off g@(LGraph _ _) =
 233   fold_blocks (fold_fwd_block first add_regslots last)
 234               (Map.singleton (CallArea Old) entry_off) g
 235   where first _  z = z
 236         last l@(LastOther (LastCall _ Nothing args res _)) z =
 237           add_regslots l (add (add z area args) area res)
 238           where area = CallArea Old
 239         last l@(LastOther (LastCall _ (Just k) args res _)) z =
 240           add_regslots l (add (add z area args) area res)
 241           where area = CallArea (Young k)
 242         last l z = add_regslots l z
 243         add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
 244         addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) =
 245           add z a $ widthInBytes $ typeWidth ty
 246         addSlot z _ = z
 247         add z a off = Map.insert a (max off (Map.findWithDefault 0 a z)) z
 248         -- The 'max' is important.  Two calls, to f and g, might share a common
 249         -- continuation (and hence a common CallArea), but their number of overflow
 250         -- parameters might differ.
 251
 252
 253 -- Find the Stack slots occupied by the subarea's conflicts
 254 conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
 255 conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
 256   foldNodes subarea foldNode Map.empty
 257   where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig
 258         conflict n' () set = liveInSlots areaMap n' set
 259         -- Add stack slots occupied by igraph node n
 260         liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
 261         setAdd w s = Map.insert w () s
 262
 263 -- Find any open space on the stack, starting from the offset.
 264 -- If the area is a CallArea or a spill slot for a pointer, then it must
 265 -- be word-aligned.
 266 freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
 267 freeSlotFrom ig areaSize offset areaMap area =
 268   let size = Map.lookup area areaSize `orElse` 0
 269       conflicts = conflictSlots ig areaSize areaMap (area, size, size)
 270       -- CallAreas and Ptrs need to be word-aligned (round up!)
 271       align = case area of CallArea _                                -> align'
 272                            RegSlot  r | isGcPtrType (localRegType r) -> align'
 273                            RegSlot  _                                -> id
 274       align' n = (n + (wORD_SIZE - 1)) `div` wORD_SIZE * wORD_SIZE
 275       -- Find a space big enough to hold the area
 276       findSpace curr 0 = curr
 277       findSpace curr cnt = -- part of target slot, # of bytes left to check
 278         if Map.member curr conflicts then
 279           findSpace (align (curr + size)) size -- try the next (possibly) open space
 280         else findSpace (curr - 1) (cnt - 1)
 281   in findSpace (align (offset + size)) size
 282
 283 -- Find an open space on the stack, and assign it to the area.
 284 allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
 285 allocSlotFrom ig areaSize from areaMap area =
 286   if Map.member area areaMap then areaMap
 287   else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap
 288
 289 -- | Greedy stack layout.
 290 -- Compute liveness, build the interference graph, and allocate slots for the areas.
 291 -- We visit each basic block in a (generally) forward order.
 292
 293 -- At each instruction that names a register subarea r, we immediately allocate
 294 -- any available slot on the stack by the following procedure:
 295 --  1. Find the sub-areas S that conflict with r
 296 --  2. Find the stack slots used for S
 297 --  3. Choose a contiguous stack space s not in S (s must be large enough to hold r)
 298
 299 -- For a CallArea, we allocate the stack space only when we reach a function
 300 -- call that returns to the CallArea's blockId.
 301 -- Then, we allocate the Area subject to the following constraints:
 302 --   a) It must be younger than all the sub-areas that are live on entry to the block
 303 --         This constraint is only necessary for the successor of a call
 304 --   b) It must not overlap with any already-allocated Area with which it conflicts
 305 --         (ie at some point, not necessarily now, is live at the same time)
 306 --   Part (b) is just the 1,2,3 part above
 307
 308 -- Note: The stack pointer only has to be younger than the youngest live stack slot
 309 -- at proc points. Otherwise, the stack pointer can point anywhere.
 310
 311 layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap
 312 -- The domain of the returned map includes an Area for EVERY block
 313 -- including each block that is not the successor of a call (ie is not a proc-point)
 314 -- That's how we return the info of what the SP should be at the entry of every block
 315
 316 layout procPoints env entry_off g =
 317   let ig = (igraph areaBuilder env g, areaBuilder)
 318       env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
 319       areaSize = getAreaSize entry_off g
 320       -- Find the slots that are live-in to a block tail
 321       live_in (ZTail m l) = liveInSlots m (live_in l)
 322       live_in (ZLast (LastOther l)) = liveLastIn l env'
 323       live_in (ZLast LastExit) = Map.empty
 324
 325       -- Find the youngest live stack slot that has already been allocated
 326       youngest_live :: AreaMap     -- Already allocated
 327                     -> SubAreaSet  -- Sub-areas live here
 328                     -> ByteOff     -- Offset of the youngest byte of any
 329                                    --    already-allocated, live sub-area
 330       youngest_live areaMap live = fold_subareas young_slot live 0
 331         where young_slot (a, o, _) z = case Map.lookup a areaMap of
 332                                          Just top -> max z $ top + o
 333                                          Nothing  -> z
 334               fold_subareas f m z = Map.foldRightWithKey (\_ s z -> foldr f z s) z m
 335
 336       -- Allocate space for spill slots and call areas
 337       allocVarSlot = allocSlotFrom ig areaSize 0
 338
 339       -- Update the successor's incoming SP.
 340       setSuccSPs inSp bid areaMap =
 341         case (Map.lookup area areaMap, lookupBlockEnv (lg_blocks g) bid) of
 342           (Just _, _) -> areaMap -- succ already knows incoming SP
 343           (Nothing, Just (Block _ _)) ->
 344             if elemBlockSet bid procPoints then
 345               let young = youngest_live areaMap $ env' bid
 346                   -- start = case returnOff stackInfo of Just b  -> max b young
 347                   --                                     Nothing -> young
 348                   start = young -- maybe wrong, but I don't understand
 349                                 -- why the preceding is necessary...
 350               in  allocSlotFrom ig areaSize start areaMap area
 351             else Map.insert area inSp areaMap
 352           (_, Nothing) -> panic "Block not found in cfg"
 353         where area = CallArea (Young bid)
 354
 355       allocLast (Block id _) areaMap l =
 356         fold_succs (setSuccSPs inSp) l areaMap
 357         where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap
 358
 359       allocMidCall m@(MidForeignCall (Safe bid _ _) _ _ _) t areaMap =
 360         let young     = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
 361             area      = CallArea (Young bid)
 362             areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize
 363         in  allocSlotFrom ig areaSize' young areaMap area
 364       allocMidCall _ _ areaMap = areaMap
 365
 366       alloc m t areaMap =
 367           foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m
 368         where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
 369               alloc' areaMap _ = areaMap
 370
 371       layoutAreas areaMap b@(Block _ t) = layout areaMap t
 372         where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
 373               layout areaMap (ZLast l)   = allocLast b areaMap l
 374       initMap = Map.insert (CallArea (Young (lg_entry g))) 0
 375                            (Map.insert (CallArea Old) 0 Map.empty)
 376       areaMap = foldl layoutAreas initMap (postorder_dfs g)
 377   in -- pprTrace "ProcPoints" (ppr procPoints) $
 378         -- pprTrace "Area SizeMap" (ppr areaSize) $
 379          -- pprTrace "Entry SP" (ppr entrySp) $
 380            -- pprTrace "Area Map" (ppr areaMap) $
 381      areaMap
 382
 383 -- After determining the stack layout, we can:
 384 -- 1. Replace references to stack Areas with addresses relative to the stack
 385 --    pointer.
 386 -- 2. Insert adjustments to the stack pointer to ensure that it is at a
 387 --    conventional location at each proc point.
 388 --    Because we don't take interrupts on the execution stack, we only need the
 389 --    stack pointer to be younger than the live values on the stack at proc points.
 390 -- 3. Compute the maximum stack offset used in the procedure and replace
 391 --    the stack high-water mark with that offset.
 392 manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Middle Last)
 393 manifestSP areaMap entry_off g@(LGraph entry _blocks) =
 394   liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
 395   where slot a = -- pprTrace "slot" (ppr a) $
 396                    Map.lookup a areaMap `orElse` panic "unallocated Area"
 397         slot' (Just id) = slot $ CallArea (Young id)
 398         slot' Nothing   = slot $ CallArea Old
 399         sp_high = maxSlot slot g
 400         proc_entry_sp = slot (CallArea Old) + entry_off
 401
 402         add_sp_off b env =
 403           case Z.last (unzip b) of
 404             LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) ->
 405               extendBlockEnv env succ off
 406             _ -> env
 407         spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g
 408         spOffset id = lookupBlockEnv spEntryMap id `orElse` 0
 409
 410         sp_on_entry id | id == entry = proc_entry_sp
 411         sp_on_entry id = slot' (Just id) + spOffset id
 412
 413         -- On entry to procpoints, the stack pointer is conventional;
 414         -- otherwise, we check the SP set by predecessors.
 415         replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
 416         replB blocks (Block id t) =
 417           do bs <- replTail (Block id) spIn t
 418              -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do
 419              liftM (flip (foldr insertBlock) bs) blocks
 420           where spIn = sp_on_entry id
 421         replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
 422                     FuelMonad ([CmmBlock])
 423         replTail h spOff (ZTail m@(MidForeignCall (Safe bid _ _) _ _ _) t) =
 424           replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
 425             where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
 426         replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
 427         replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l
 428         replTail h _   l@(ZLast LastExit) = return [h l]
 429         middle spOff m = mapExpDeepMiddle (replSlot spOff) m
 430         last   spOff l = mapExpDeepLast   (replSlot spOff) l
 431         replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
 432         replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
 433           CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
 434         replSlot _ e = e
 435         -- The block must establish the SP expected at each successsor.
 436         fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
 437         fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l
 438         fixSp h spOff l@(LastBranch k) =
 439           let succSp = sp_on_entry k in
 440           if succSp /= spOff then
 441                -- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
 442                updSp h spOff succSp l
 443           else return $ [h (ZLast (LastOther (last spOff l)))]
 444         fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
 445           where b = h (ZLast (LastOther (last spOff l)))
 446                 succ succId z =
 447                   let succSp = sp_on_entry succId in
 448                   if succSp /= spOff then
 449                     do (b,  bs)  <- z
 450                        (b', bs') <- insertBetween b [setSpMid spOff succSp] succId
 451                        return (b', bs ++ bs')
 452                   else z
 453         updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)]
 454         setSpMid sp sp' = MidAssign (CmmGlobal Sp) e
 455           where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
 456                 off = CmmLit $ CmmInt (toInteger $ sp - sp') wordWidth
 457         setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t
 458
 459
 460 -- To compute the stack high-water mark, we fold over the graph and
 461 -- compute the highest slot offset.
 462 maxSlot :: (Area -> Int) -> CmmGraph -> Int
 463 maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g
 464   where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
 465         add z (a, i, _) = max z (slotOff a + i)
 466
 467 -----------------------------------------------------------------------------
 468 -- | Sanity check: stub pointers immediately after they die
 469 -----------------------------------------------------------------------------
 470 -- This will miss stack slots that are last used in a Last node,
 471 -- but it should do pretty well...
 472
 473 type StubPtrFix = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet CmmGraph)
 474
 475 stubSlotsOnDeath :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
 476 stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix)
 477     where res = zdfBRewriteFromL RewriteShallow emptyBlockEnv "stub ptrs" slotLattice
 478                                  liveSlotTransfers rewrites (fact_bot slotLattice) g
 479           rewrites = BackwardRewrites first middle last Nothing
 480           first _ _ = Nothing
 481           last  _ _ = Nothing
 482           middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m
 483           stub liveSlots m rst subarea@(a, off, w) =
 484             if elemSlot liveSlots subarea then rst
 485             else let store = mkStore (CmmStackSlot a off)
 486                                      (stackStubExpr (widthFromBytes w))
 487                  in case rst of Nothing -> Just (mkMiddle m <*> store)
 488                                 Just g  -> Just (g <*> store)