Remove code that is dead now that we need >= 6.12 to build
[ghc-hetmet.git] / compiler / cmm / CmmStackLayout.hs
index 17a819f..df1b89c 100644 (file)
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmStackLayout
     ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
     , layout, manifestSP, igraph, areaBuilder
@@ -5,7 +9,6 @@ module CmmStackLayout
 where
 
 import Constants
-import qualified Prelude as P
 import Prelude hiding (zip, unzip, last)
 
 import BlockId
@@ -13,17 +16,21 @@ import CmmExpr
 import CmmProcPointZ
 import CmmTx
 import DFMonad
-import FiniteMap
 import Maybes
 import MkZipCfg
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
-import Monad
+import Control.Monad
 import Outputable
-import Panic
+import SMRep (ByteOff)
 import ZipCfg
+import ZipCfg as Z
 import ZipCfgCmmRep
 import ZipDataflow
 
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+
 ------------------------------------------------------------------------
 --                    Stack Layout                                    --
 ------------------------------------------------------------------------
@@ -57,16 +64,18 @@ import ZipDataflow
 -- a single slot, on insertion.
 
 slotLattice :: DataflowLattice SubAreaSet
-slotLattice = DataflowLattice "live slots" emptyFM add False
-  where add new old = case foldFM addArea (False, old) new of
+slotLattice = DataflowLattice "live slots" Map.empty add False
+  where add new old = case Map.foldRightWithKey addArea (False, old) new of
                         (True,  x) -> aTx  x
                         (False, x) -> noTx x
         addArea a newSlots z = foldr (addSlot a) z newSlots
         addSlot a slot (changed, map) =
-          let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a
-          in (c || changed, addToFM map a live)
+          let (c, live) = liveGen slot $ Map.findWithDefault [] a map
+          in (c || changed, Map.insert a live map)
 
 type SlotEnv   = BlockEnv SubAreaSet
+  -- The sub-areas live on entry to the block
+
 type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a)
 
 liveSlotAnal :: LGraph Middle Last -> FuelMonad SlotEnv
@@ -114,26 +123,26 @@ liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $
 liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
 liveSlotTransfers =
   BackwardTransfers first liveInSlots liveLastIn
-    where first live id = delFromFM live (CallArea (Young id))
+    where first id live = Map.delete (CallArea (Young id)) live
 
 -- Slot sets: adding slots, removing slots, and checking for membership.
 liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet 
 addSlot, removeSlot :: SubAreaSet -> SubArea -> SubAreaSet
 elemSlot            :: SubAreaSet -> SubArea -> Bool
-liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a)
+liftToArea a f map = Map.insert a (f (Map.findWithDefault [] a map)) map
 addSlot    live (a, i, w) = liftToArea a (snd . liveGen  (a, i, w)) live
 removeSlot live (a, i, w) = liftToArea a       (liveKill (a, i, w)) live
 elemSlot   live (a, i, w) =
-  not $ fst $ liveGen  (a, i, w) (lookupWithDefaultFM live [] a)
+  not $ fst $ liveGen  (a, i, w) (Map.findWithDefault [] a live)
 
 removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
 removeLiveSlotDefs = foldSlotsDefd removeSlot
 
-liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
-liveInSlots live x = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
+liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet
+liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
 
-liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
-liveLastIn env l = liveInSlots (liveLastOut env l) l
+liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet
+liveLastIn l env = liveInSlots l (liveLastOut env l)
 
 -- Don't forget to keep the outgoing parameters in the CallArea live,
 -- as well as the update frame.
@@ -145,17 +154,17 @@ liveLastIn env l = liveInSlots (liveLastOut env l) l
 liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
 liveLastOut env l =
   case l of
-    LastCall _ Nothing n _ -> 
+    LastCall _ Nothing n _ _ -> 
       add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
-    LastCall _ (Just k) n (Just _) ->
+    LastCall _ (Just k) n _ (Just _) ->
       add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
-    LastCall _ (Just k) n Nothing ->
+    LastCall _ (Just k) n _ Nothing ->
       add_area (CallArea (Young k)) n out
     _ -> out
   where out = joinOuts slotLattice env l
         add_area _ n live | n == 0 = live
         add_area a n live =
-          addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a
+          Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live
 
 -- The liveness analysis must be precise: otherwise, we won't know if a definition
 -- should really kill a live-out stack slot.
@@ -166,7 +175,7 @@ liveLastOut env l =
 -- every time, I provide a function to fold over the nodes, which should be a
 -- reasonably efficient approach for the implementations we envision.
 -- Of course, it will probably be much easier to program if we just return a list...
-type Set x = FiniteMap x ()
+type Set x = Map x ()
 data IGraphBuilder n =
   Builder { foldNodes     :: forall z. SubArea -> (n -> z -> z) -> z -> z
           , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
@@ -176,8 +185,8 @@ areaBuilder :: IGraphBuilder Area
 areaBuilder = Builder fold words
   where fold (a, _, _) f z = f a z
         words areaSize areaMap a =
-          case lookupFM areaMap a of
-            Just addr -> [addr .. addr + (lookupFM areaSize a `orElse`
+          case Map.lookup a areaMap of
+            Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse`
                                           pprPanic "wordsOccupied: unknown area" (ppr a))]
             Nothing   -> []
 
@@ -187,69 +196,76 @@ areaBuilder = Builder fold words
 -- Now, we can build the interference graph.
 -- The usual story: a definition interferes with all live outs and all other
 -- definitions.
-type IGraph x = FiniteMap x (Set x)
+type IGraph x = Map x (Set x)
 type IGPair x = (IGraph x, IGraphBuilder x)
 igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x
-igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
+igraph builder env g = foldr interfere Map.empty (postorder_dfs g)
   where foldN = foldNodes builder
         interfere block igraph =
           let (h, l) = goto_end (unzip block)
               --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
-              heads (ZFirst _ _) (igraph, _)       = igraph
+              heads (ZFirst _) (igraph, _)       = igraph
               heads (ZHead h m)    (igraph, liveOut) =
-                heads h (addEdges igraph m liveOut, liveInSlots liveOut m)
+                heads h (addEdges igraph m liveOut, liveInSlots m liveOut)
               -- add edges between a def and the other defs and liveouts
               addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
               addDef (igraph, out) def@(a, _, _) =
                 (foldN def (addDefN out) igraph,
-                 addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a)))
+                 Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out)
               addDefN out n igraph =
                 let addEdgeNO o igraph = foldN o addEdgeNN igraph
                     addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
-                    addEdgeNN' n n' igraph = addToFM igraph n (addToFM set n' ())
-                      where set = lookupWithDefaultFM igraph emptyFM n
-                in foldFM (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
+                    addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph
+                      where set = Map.findWithDefault Map.empty n igraph
+                in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
               env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
-          in heads h $ case l of LastExit    -> (igraph, emptyFM)
+          in heads h $ case l of LastExit    -> (igraph, Map.empty)
                                  LastOther l -> (addEdges igraph l $ liveLastOut env' l,
-                                                 liveLastIn env' l)
+                                                 liveLastIn l env')
 
 -- Before allocating stack slots, we need to collect one more piece of information:
 -- what's the highest offset (in bytes) used in each Area?
 -- We'll need to allocate that much space for each Area.
-getAreaSize :: LGraph Middle Last -> AreaMap
-getAreaSize g@(LGraph _ off _) =
+getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap
+  -- The domain of the returned mapping consists only of Areas
+  -- used for (a) variable spill slots, and (b) parameter passing ares for calls
+getAreaSize entry_off g@(LGraph _ _) =
   fold_blocks (fold_fwd_block first add_regslots last)
-              (unitFM (CallArea Old) off) g
-  where first id (StackInfo {argBytes = Just off}) z = add z (CallArea (Young id)) off
-        first _  _          z = z
-        add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
-        last l@(LastOther (LastCall _ Nothing off _)) z =
-          add_regslots l (add z (CallArea Old) off)
-        last l@(LastOther (LastCall _ (Just k) off _)) z =
-          add_regslots l (add z (CallArea (Young k)) off)
+              (Map.singleton (CallArea Old) entry_off) g
+  where first _  z = z
+        last l@(LastOther (LastCall _ Nothing args res _)) z =
+          add_regslots l (add (add z area args) area res)
+          where area = CallArea Old
+        last l@(LastOther (LastCall _ (Just k) args res _)) z =
+          add_regslots l (add (add z area args) area res)
+          where area = CallArea (Young k)
         last l z = add_regslots l z
-        addSlot z (a@(RegSlot _), off, _) = add z a off
+        add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
+        addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) =
+          add z a $ widthInBytes $ typeWidth ty
         addSlot z _ = z
-        add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a))
+        add z a off = Map.insert a (max off (Map.findWithDefault 0 a z)) z
+       -- The 'max' is important.  Two calls, to f and g, might share a common
+       -- continuation (and hence a common CallArea), but their number of overflow
+       -- parameters might differ.
 
 
 -- Find the Stack slots occupied by the subarea's conflicts
 conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
 conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
-  foldNodes subarea foldNode emptyFM
-  where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n
+  foldNodes subarea foldNode Map.empty
+  where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig
         conflict n' () set = liveInSlots areaMap n' set
         -- Add stack slots occupied by igraph node n
         liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
-        setAdd w s = addToFM s w ()
+        setAdd w s = Map.insert w () s
 
 -- Find any open space on the stack, starting from the offset.
 -- If the area is a CallArea or a spill slot for a pointer, then it must
 -- be word-aligned.
 freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
 freeSlotFrom ig areaSize offset areaMap area =
-  let size = lookupFM areaSize area `orElse` 0
+  let size = Map.lookup area areaSize `orElse` 0
       conflicts = conflictSlots ig areaSize areaMap (area, size, size)
       -- CallAreas and Ptrs need to be word-aligned (round up!)
       align = case area of CallArea _                                -> align'
@@ -259,7 +275,7 @@ freeSlotFrom ig areaSize offset areaMap area =
       -- Find a space big enough to hold the area
       findSpace curr 0 = curr
       findSpace curr cnt = -- part of target slot, # of bytes left to check
-        if elemFM curr conflicts then
+        if Map.member curr conflicts then
           findSpace (align (curr + size)) size -- try the next (possibly) open space
         else findSpace (curr - 1) (cnt - 1)
   in findSpace (align (offset + size)) size
@@ -267,69 +283,99 @@ freeSlotFrom ig areaSize offset areaMap area =
 -- Find an open space on the stack, and assign it to the area.
 allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
 allocSlotFrom ig areaSize from areaMap area =
-  if elemFM area areaMap then areaMap
-  else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area
+  if Map.member area areaMap then areaMap
+  else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap
 
 -- | Greedy stack layout.
 -- Compute liveness, build the interference graph, and allocate slots for the areas.
 -- We visit each basic block in a (generally) forward order.
+
 -- At each instruction that names a register subarea r, we immediately allocate
 -- any available slot on the stack by the following procedure:
---  1. Find the nodes N' that conflict with r
---  2. Find the stack slots used for N'
---  3. Choose a contiguous stack space s not in N' (s must be large enough to hold r)
+--  1. Find the sub-areas S that conflict with r
+--  2. Find the stack slots used for S
+--  3. Choose a contiguous stack space s not in S (s must be large enough to hold r)
+
 -- For a CallArea, we allocate the stack space only when we reach a function
 -- call that returns to the CallArea's blockId.
--- We use a similar procedure, with one exception: the stack space
--- must be allocated below the youngest stack slot that is live out.
+-- Then, we allocate the Area subject to the following constraints:
+--   a) It must be younger than all the sub-areas that are live on entry to the block
+--         This constraint is only necessary for the successor of a call
+--   b) It must not overlap with any already-allocated Area with which it conflicts
+--        (ie at some point, not necessarily now, is live at the same time)
+--   Part (b) is just the 1,2,3 part above
 
 -- Note: The stack pointer only has to be younger than the youngest live stack slot
 -- at proc points. Otherwise, the stack pointer can point anywhere.
-layout :: ProcPointSet -> SlotEnv -> LGraph Middle Last -> AreaMap
-layout procPoints env g =
-  let builder = areaBuilder
-      ig = (igraph builder env g, builder)
+
+layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap
+-- The domain of the returned map includes an Area for EVERY block
+-- including each block that is not the successor of a call (ie is not a proc-point)
+-- That's how we return the info of what the SP should be at the entry of every block
+
+layout procPoints env entry_off g =
+  let ig = (igraph areaBuilder env g, areaBuilder)
       env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
-      areaSize = getAreaSize g
-      -- Find the slots that are live-in to the block
-      live_in (ZTail m l) = liveInSlots (live_in l) m
-      live_in (ZLast (LastOther l)) = liveLastIn env' l
-      live_in (ZLast LastExit) = emptyFM 
-      -- Find the youngest live stack slot
+      areaSize = getAreaSize entry_off g
+      -- Find the slots that are live-in to a block tail
+      live_in (ZTail m l) = liveInSlots m (live_in l)
+      live_in (ZLast (LastOther l)) = liveLastIn l env'
+      live_in (ZLast LastExit) = Map.empty 
+
+      -- Find the youngest live stack slot that has already been allocated
+      youngest_live :: AreaMap            -- Already allocated
+                    -> SubAreaSet  -- Sub-areas live here
+                   -> ByteOff     -- Offset of the youngest byte of any 
+                                  --    already-allocated, live sub-area
       youngest_live areaMap live = fold_subareas young_slot live 0
-        where young_slot (a, o, _) z = case lookupFM areaMap a of
+        where young_slot (a, o, _) z = case Map.lookup a areaMap of
                                          Just top -> max z $ top + o
                                          Nothing  -> z
-      fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z
-      fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
+              fold_subareas f m z = Map.foldRightWithKey (\_ s z -> foldr f z s) z m
+
       -- Allocate space for spill slots and call areas
       allocVarSlot = allocSlotFrom ig areaSize 0
-      allocCallSlot areaMap (Block id stackInfo t)
-        | elemBlockSet id procPoints =
-        let young  = youngest_live areaMap $ live_in t
-            start = case returnOff stackInfo of Just b  -> max b young
-                                                Nothing -> young
-            z = allocSlotFrom ig areaSize start areaMap (CallArea (Young id))
-        in -- pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z) 
-           z
-      allocCallSlot areaMap _ = areaMap
-      -- mid foreign calls need to have info tables placed on the stack
-      allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
+
+      -- Update the successor's incoming SP.
+      setSuccSPs inSp bid areaMap =
+        case (Map.lookup area areaMap, lookupBlockEnv (lg_blocks g) bid) of
+          (Just _, _) -> areaMap -- succ already knows incoming SP
+          (Nothing, Just (Block _ _)) ->
+            if elemBlockSet bid procPoints then
+              let young = youngest_live areaMap $ env' bid
+                  -- start = case returnOff stackInfo of Just b  -> max b young
+                  --                                     Nothing -> young
+                  start = young -- maybe wrong, but I don't understand
+                                -- why the preceding is necessary...
+              in  allocSlotFrom ig areaSize start areaMap area
+            else Map.insert area inSp areaMap
+          (_, Nothing) -> panic "Block not found in cfg"
+        where area = CallArea (Young bid)
+
+      allocLast (Block id _) areaMap l =
+        fold_succs (setSuccSPs inSp) l areaMap
+        where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap
+
+      allocMidCall m@(MidForeignCall (Safe bid _ _) _ _ _) t areaMap =
         let young     = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
             area      = CallArea (Young bid)
-            areaSize' = addToFM areaSize area (widthInBytes (typeWidth gcWord))
+            areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize
         in  allocSlotFrom ig areaSize' young areaMap area
       allocMidCall _ _ areaMap = areaMap
+
       alloc m t areaMap =
           foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m
         where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
               alloc' areaMap _ = areaMap
-      layoutAreas areaMap b@(Block _ _ t) = layout areaMap t
+
+      layoutAreas areaMap b@(Block _ t) = layout areaMap t
         where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
-              layout areaMap (ZLast _)   = allocCallSlot areaMap b
-      areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) (postorder_dfs g)
+              layout areaMap (ZLast l)   = allocLast b areaMap l
+      initMap = Map.insert (CallArea (Young (lg_entry g))) 0
+                           (Map.insert (CallArea Old) 0 Map.empty)
+      areaMap = foldl layoutAreas initMap (postorder_dfs g)
   in -- pprTrace "ProcPoints" (ppr procPoints) $
-       -- pprTrace "Area SizeMap" (ppr areaSize) $
+        -- pprTrace "Area SizeMap" (ppr areaSize) $
          -- pprTrace "Entry SP" (ppr entrySp) $
            -- pprTrace "Area Map" (ppr areaMap) $
      areaMap
@@ -343,41 +389,38 @@ layout procPoints env g =
 --    stack pointer to be younger than the live values on the stack at proc points.
 -- 3. Compute the maximum stack offset used in the procedure and replace
 --    the stack high-water mark with that offset.
-manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap ->
-                LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
-  liftM (LGraph entry args) blocks'
-  where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g)
-        slot a = -- pprTrace "slot" (ppr a) $
-                   lookupFM areaMap a `orElse` panic "unallocated Area"
+manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Middle Last)
+manifestSP areaMap entry_off g@(LGraph entry _blocks) =
+  liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
+  where slot a = -- pprTrace "slot" (ppr a) $
+                   Map.lookup a areaMap `orElse` panic "unallocated Area"
         slot' (Just id) = slot $ CallArea (Young id)
         slot' Nothing   = slot $ CallArea Old
         sp_high = maxSlot slot g
-        proc_entry_sp = slot (CallArea Old) + args
+        proc_entry_sp = slot (CallArea Old) + entry_off
+
+        add_sp_off b env =
+          case Z.last (unzip b) of
+            LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) ->
+              extendBlockEnv env succ off
+            _ -> env
+        spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g
+        spOffset id = lookupBlockEnv spEntryMap id `orElse` 0
+
         sp_on_entry id | id == entry = proc_entry_sp
-        sp_on_entry id =
-          case lookupBlockEnv blocks id of
-            Just (Block _ (StackInfo {argBytes = Just o}) _) -> slot' (Just id) + o
-            _ -> 
-             case expectJust "sp_on_entry" (lookupBlockEnv procMap id) of
-               ReachedBy pp ->
-                 case blockSetToList pp of
-                   [id] -> sp_on_entry id
-                   _    -> panic "block not reached by one proc point"
-               ProcPoint -> pprPanic "procpoint doesn't take any arguments?"
-                               (ppr id <+> ppr g <+> ppr procPoints <+> ppr procMap)
+        sp_on_entry id = slot' (Just id) + spOffset id
 
         -- On entry to procpoints, the stack pointer is conventional;
         -- otherwise, we check the SP set by predecessors.
         replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
-        replB blocks (Block id o t) =
-          do bs <- replTail (Block id o) spIn t
+        replB blocks (Block id t) =
+          do bs <- replTail (Block id) spIn t
              -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do
              liftM (flip (foldr insertBlock) bs) blocks
           where spIn = sp_on_entry id
         replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> 
                     FuelMonad ([CmmBlock])
-        replTail h spOff (ZTail m@(MidForeignCall (Safe bid _) _ _ _) t) =
+        replTail h spOff (ZTail m@(MidForeignCall (Safe bid _ _) _ _ _) t) =
           replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
             where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
         replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
@@ -391,7 +434,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
         replSlot _ e = e
         -- The block must establish the SP expected at each successsor.
         fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
-        fixSp h spOff l@(LastCall _ k n _) = updSp h spOff (slot' k + n) l
+        fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l
         fixSp h spOff l@(LastBranch k) =
           let succSp = sp_on_entry k in
           if succSp /= spOff then
@@ -417,7 +460,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
 -- To compute the stack high-water mark, we fold over the graph and
 -- compute the highest slot offset.
 maxSlot :: (Area -> Int) -> CmmGraph -> Int
-maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ _ x -> x) highSlot highSlot) 0 g
+maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g
   where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
         add z (a, i, _) = max z (slotOff a + i)
 
@@ -436,7 +479,7 @@ stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix)
           rewrites = BackwardRewrites first middle last Nothing
           first _ _ = Nothing
           last  _ _ = Nothing
-          middle liveSlots m = foldSlotsUsed (stub liveSlots m) Nothing m
+          middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m
           stub liveSlots m rst subarea@(a, off, w) =
             if elemSlot liveSlots subarea then rst
             else let store = mkStore (CmmStackSlot a off)