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