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