compiler/cmm/CmmStackLayout.hs

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