compiler/cmm/CmmStackLayout.hs

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