Generate (old + 0) instead of Sp in stack checks
[ghc.git] / compiler / cmm / CmmLayoutStack.hs
index 660506e..4ac5725 100644 (file)
@@ -1,38 +1,36 @@
 {-# LANGUAGE RecordWildCards, GADTs #-}
 module CmmLayoutStack (
-       cmmLayoutStack, setInfoTableStackMap, cmmSink
+       cmmLayoutStack, setInfoTableStackMap
   ) where
 
-import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX
-import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX
+import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
+import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
 
+import BasicTypes
 import Cmm
+import CmmInfo
 import BlockId
 import CLabel
 import CmmUtils
 import MkGraph
-import Module
 import ForeignCall
 import CmmLive
 import CmmProcPoint
 import SMRep
-import Hoopl hiding ((<*>), mkLast, mkMiddle)
-import OptimizationFuel
-import Constants
+import Hoopl
 import UniqSupply
 import Maybes
 import UniqFM
 import Util
 
+import DynFlags
 import FastString
 import Outputable
-import Data.Map (Map)
-import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Control.Monad.Fix
 import Data.Array as Array
 import Data.Bits
-import Data.List (nub, partition)
+import Data.List (nub)
 import Control.Monad (liftM)
 
 #include "HsVersions.h"
@@ -104,30 +102,37 @@ instance Outputable StackMap where
      text "sm_regs = " <> ppr (eltsUFM sm_regs)
 
 
-cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
-               -> FuelUniqSM (CmmGraph, BlockEnv StackMap)
-cmmLayoutStack procpoints entry_args
+cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
+               -> UniqSM (CmmGraph, BlockEnv StackMap)
+cmmLayoutStack dflags procpoints entry_args
                graph0@(CmmGraph { g_entry = entry })
   = do
-    pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
-    (graph, liveness) <- removeDeadAssignments graph0
-    pprTrace "liveness" (ppr liveness) $ return ()
+    -- pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
+
+    -- We need liveness info.  We could do removeDeadAssignments at
+    -- the same time, but it buys nothing over doing cmmSink later,
+    -- and costs a lot more than just cmmLocalLiveness.
+    -- (graph, liveness) <- removeDeadAssignments graph0
+    let (graph, liveness) = (graph0, cmmLocalLiveness dflags graph0)
+
+    -- pprTrace "liveness" (ppr liveness) $ return ()
     let blocks = postorderDfs graph
 
-    (final_stackmaps, final_high_sp, new_blocks) <- liftUniq $
+    (final_stackmaps, _final_high_sp, new_blocks) <-
           mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
-            layout procpoints liveness entry entry_args
+            layout dflags procpoints liveness entry entry_args
                    rec_stackmaps rec_high_sp blocks
 
-    new_blocks' <- liftUniq $ mapM lowerSafeForeignCall new_blocks
+    new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks
 
-    pprTrace ("Sp HWM") (ppr final_high_sp) $
-       return (ofBlockList entry new_blocks', final_stackmaps)
+    -- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return ()
+    return (ofBlockList entry new_blocks', final_stackmaps)
 
 
 
-layout :: BlockSet                      -- proc points
-       -> BlockEnv CmmLive              -- liveness
+layout :: DynFlags
+       -> BlockSet                      -- proc points
+       -> BlockEnv CmmLocalLive         -- liveness
        -> BlockId                       -- entry
        -> ByteOff                       -- stack args on entry
 
@@ -142,7 +147,7 @@ layout :: BlockSet                      -- proc points
           , [CmmBlock]                  -- [out] new blocks
           )
 
-layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
+layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks
   = go blocks init_stackmap entry_args []
   where
     (updfr, cont_info)  = collectContInfo blocks
@@ -159,34 +164,34 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
     go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
       = do
        let (entry0@(CmmEntry entry_lbl), middle0, last0) = blockSplit b0
-    
+
        let stack0@StackMap { sm_sp = sp0 }
                = mapFindWithDefault
                      (pprPanic "no stack map for" (ppr entry_lbl))
                      entry_lbl acc_stackmaps
-    
-       pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return ()
-    
+
+       -- pprTrace "layout" (ppr entry_lbl <+> ppr stack0) $ return ()
+
        -- (a) Update the stack map to include the effects of
        --     assignments in this block
        let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0
-    
+
        -- (b) Insert assignments to reload all the live variables if this
        --     block is a proc point
        let middle1 = if entry_lbl `setMember` procpoints
                         then foldr blockCons middle0 (insertReloads stack0)
                         else middle0
-    
+
        -- (c) Look at the last node and if we are making a call or
        --     jumping to a proc point, we must save the live
        --     variables, adjust Sp, and construct the StackMaps for
        --     each of the successor blocks.  See handleLastNode for
        --     details.
        (middle2, sp_off, last1, fixup_blocks, out)
-           <- handleLastNode procpoints liveness cont_info
+           <- handleLastNode dflags procpoints liveness cont_info
                              acc_stackmaps stack1 middle0 last0
-    
-       pprTrace "layout(out)" (ppr out) $ return ()
+
+       -- pprTrace "layout(out)" (ppr out) $ return ()
 
        -- (d) Manifest Sp: run over the nodes in the block and replace
        --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
@@ -199,25 +204,36 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
        --
        let middle_pre = blockToList $ foldl blockSnoc middle1 middle2
 
-           sp_high = final_hwm - entry_args
-              -- The stack check value is adjusted by the Sp offset on
-              -- entry to the proc, which is entry_args.  We are
-              -- assuming that we only do a stack check at the
-              -- beginning of a proc, and we don't modify Sp before the
-              -- check.
-
-           final_blocks = manifestSp final_stackmaps stack0 sp0 sp_high entry0
+           final_blocks = manifestSp dflags final_stackmaps stack0 sp0 final_sp_high entry0
                               middle_pre sp_off last1 fixup_blocks
 
            acc_stackmaps' = mapUnion acc_stackmaps out
 
-           hwm' = maximum (acc_hwm : (sp0 - sp_off) : map sm_sp (mapElems out))
+           -- If this block jumps to the GC, then we do not take its
+           -- stack usage into account for the high-water mark.
+           -- Otherwise, if the only stack usage is in the stack-check
+           -- failure block itself, we will do a redundant stack
+           -- check.  The stack has a buffer designed to accommodate
+           -- the largest amount of stack needed for calling the GC.
+           --
+           this_sp_hwm | isGcJump last0 = 0
+                       | otherwise      = sp0 - sp_off
+
+           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))
 
        go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
 
 
 -- -----------------------------------------------------------------------------
 
+-- Not foolproof, but GCFun is the culprit we most want to catch
+isGcJump :: CmmNode O C -> Bool
+isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })
+  = l == GCFun || l == GCEnter1
+isGcJump _something_else = False
+
+-- -----------------------------------------------------------------------------
+
 -- This doesn't seem right somehow.  We need to find out whether this
 -- proc will push some update frame material at some point, so that we
 -- can avoid using that area of the stack for spilling.  The
@@ -235,12 +251,13 @@ collectContInfo blocks
  where
   (mb_argss, ret_offs) = mapAndUnzip get_cont blocks
 
+  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
   get_cont b =
      case lastNode b of
         CmmCall { cml_cont = Just l, .. }
            -> (Just (l, cml_ret_args), cml_ret_off)
         CmmForeignCall { .. }
-           -> (Just (succ, 0), updfr) -- ??
+           -> (Just (succ, ret_args), ret_off)
         _other -> (Nothing, 0)
 
 
@@ -248,7 +265,7 @@ collectContInfo blocks
 -- Updating the StackMap from middle nodes
 
 -- Look for loads from stack slots, and update the StackMap.  This is
--- purelyu for optimisation reasons, so that we can avoid saving a
+-- purely for optimisation reasons, so that we can avoid saving a
 -- variable back to a different stack slot if it is already on the
 -- stack.
 --
@@ -295,7 +312,7 @@ getStackLoc (Young l) n stackmaps =
 -- extra code that goes *after* the Sp adjustment.
 
 handleLastNode
-   :: ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff
+   :: DynFlags -> ProcPointSet -> BlockEnv CmmLocalLive -> BlockEnv ByteOff
    -> BlockEnv StackMap -> StackMap
    -> Block CmmNode O O
    -> CmmNode O C
@@ -307,7 +324,7 @@ handleLastNode
       , BlockEnv StackMap  -- stackmaps for the continuations
       )
 
-handleLastNode procpoints liveness cont_info stackmaps
+handleLastNode dflags procpoints liveness cont_info stackmaps
                stack0@StackMap { sm_sp = sp0 } middle last
  = case last of
     --  At each return / tail call,
@@ -322,12 +339,12 @@ handleLastNode procpoints liveness cont_info stackmaps
        return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
 
     CmmForeignCall{ succ = cont_lbl, .. } -> do
-       return $ lastCall cont_lbl wORD_SIZE wORD_SIZE (sm_ret_off stack0)
-            -- one word each for args and results: the return address
+       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
+            -- one word of args: the return address
 
-    CmmBranch{..}     ->  handleProcPoints
-    CmmCondBranch{..} ->  handleProcPoints
-    CmmSwitch{..}     ->  handleProcPoints
+    CmmBranch{..}     ->  handleBranches
+    CmmCondBranch{..} ->  handleBranches
+    CmmSwitch{..}     ->  handleBranches
 
   where
      -- Calls and ForeignCalls are handled the same way:
@@ -358,19 +375,20 @@ handleLastNode procpoints liveness cont_info stackmaps
        = (save_assignments, new_cont_stack)
        where
         (new_cont_stack, save_assignments)
-           = setupStackFrame lbl liveness cml_ret_off cml_ret_args stack0
+           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
 
 
+     -- For other last nodes (branches), if any of the targets is a
      -- proc point, we have to set up the stack to match what the proc
      -- point is expecting.
      --
-     handleProcPoints :: UniqSM ( [CmmNode O O]
+     handleBranches :: UniqSM ( [CmmNode O O]
                                 , ByteOff
                                 , CmmNode O C
                                 , [CmmBlock]
                                 , BlockEnv StackMap )
 
-     handleProcPoints
+     handleBranches
          -- Note [diamond proc point]
        | Just l <- futureContinuation middle
        , (nub $ filter (`setMember` procpoints) $ successors last) == [l]
@@ -380,58 +398,72 @@ handleLastNode procpoints liveness cont_info stackmaps
              out = mapFromList [ (l', cont_stack)
                                | l' <- successors last ]
          return ( assigs
-                , spOffsetForCall sp0 cont_stack wORD_SIZE
+                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
                 , last
                 , []
                 , out)
 
         | otherwise = do
-          pps <- mapM handleProcPoint (successors last)
+          pps <- mapM handleBranch (successors last)
           let lbl_map :: LabelMap Label
               lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
-              fix_lbl l = mapLookup l lbl_map `orElse` l
+              fix_lbl l = mapFindWithDefault l l lbl_map
           return ( []
                  , 0
                  , mapSuccessors fix_lbl last
                  , concat [ blk | (_,_,_,blk) <- pps ]
                  , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
 
-     -- For each proc point that is a successor of this block
-     --   (a) if the proc point already has a stackmap, we need to
-     --       shuffle the current stack to make it look the same.
-     --       We have to insert a new block to make this happen.
-     --   (b) otherwise, call "allocate live stack0" to make the
-     --       stack map for the proc point
-     handleProcPoint :: BlockId
-                     -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
-     handleProcPoint l
-        | not (l `setMember` procpoints) = return (l, l, stack0, [])
-        | otherwise = do
-           tmp_lbl <- liftM mkBlockId $ getUniqueM
-           let
-               (stack2, assigs) =
-                  case mapLookup l stackmaps of
-                    Just pp_sm -> (pp_sm, fixupStack stack0 pp_sm)
-                    Nothing    ->
-                      pprTrace "first visit to proc point"
-                                   (ppr l <+> ppr stack1) $
-                      (stack1, assigs)
-                      where
-                       cont_args = mapFindWithDefault 0 l cont_info
-                       (stack1, assigs) =
-                           setupStackFrame l liveness (sm_ret_off stack0)
+     -- For each successor of this block
+     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
+     handleBranch l
+        --   (a) if the successor already has a stackmap, we need to
+        --       shuffle the current stack to make it look the same.
+        --       We have to insert a new block to make this happen.
+        | Just stack2 <- mapLookup l stackmaps
+        = do
+             let assigs = fixupStack stack0 stack2
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
+             return (l, tmp_lbl, stack2, block)
+
+        --   (b) if the successor is a proc point, save everything
+        --       on the stack.
+        | l `setMember` procpoints
+        = do
+             let cont_args = mapFindWithDefault 0 l cont_info
+                 (stack2, assigs) =
+                      --pprTrace "first visit to proc point"
+                      --             (ppr l <+> ppr stack1) $
+                      setupStackFrame dflags l liveness (sm_ret_off stack0)
                                                        cont_args stack0
+             --
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs
+             return (l, tmp_lbl, stack2, block)
+
+        --   (c) otherwise, the current StackMap is the StackMap for
+        --       the continuation.  But we must remember to remove any
+        --       variables from the StackMap that are *not* live at
+        --       the destination, because this StackMap might be used
+        --       by fixupStack if this is a join point.
+        | otherwise = return (l, l, stack1, [])
+        where live = mapFindWithDefault (panic "handleBranch") l liveness
+              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
+              is_live (r,_) = r `elemRegSet` live
+
+
+makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O]
+               -> UniqSM (Label, [CmmBlock])
+makeFixupBlock dflags sp0 l stack assigs
+  | null assigs && sp0 == sm_sp stack = return (l, [])
+  | otherwise = do
+    tmp_lbl <- liftM mkBlockId $ getUniqueM
+    let sp_off = sp0 - sm_sp stack
+        block = blockJoin (CmmEntry tmp_lbl)
+                          (maybeAddSpAdj dflags sp_off (blockFromList assigs))
+                          (CmmBranch l)
+    return (tmp_lbl, [block])
 
-               sp_off = sp0 - sm_sp stack2
 
-               block = blockJoin (CmmEntry tmp_lbl)
-                                 (maybeAddSpAdj sp_off (blockFromList assigs))
-                                 (CmmBranch l)
-           --
-           return (l, tmp_lbl, stack2, [block])
-
-
-  
 -- Sp is currently pointing to current_sp,
 -- we want it to point to
 --    (sm_sp cont_stack - sm_args cont_stack + args)
@@ -447,26 +479,26 @@ spOffsetForCall current_sp cont_stack args
 fixupStack :: StackMap -> StackMap -> [CmmNode O O]
 fixupStack old_stack new_stack = concatMap move new_locs
  where
-     old_map :: Map LocalReg ByteOff
-     old_map  = Map.fromList (stackSlotRegs old_stack)
+     old_map  = sm_regs old_stack
      new_locs = stackSlotRegs new_stack
 
      move (r,n)
-       | Just m <- Map.lookup r old_map, n == m = []
+       | Just (_,m) <- lookupUFM old_map r, n == m = []
        | otherwise = [CmmStore (CmmStackSlot Old n)
                                (CmmReg (CmmLocal r))]
 
 
 
 setupStackFrame
-             :: BlockId                 -- label of continuation
-             -> BlockEnv CmmLive        -- liveness
+             :: DynFlags
+             -> BlockId                 -- label of continuation
+             -> BlockEnv CmmLocalLive   -- liveness
              -> ByteOff      -- updfr
              -> ByteOff      -- bytes of return values on stack
              -> StackMap     -- current StackMap
              -> (StackMap, [CmmNode O O])
 
-setupStackFrame lbl liveness updfr_off ret_args stack0
+setupStackFrame dflags lbl liveness updfr_off ret_args stack0
   = (cont_stack, assignments)
   where
       -- get the set of LocalRegs live in the continuation
@@ -482,7 +514,7 @@ setupStackFrame lbl liveness updfr_off ret_args stack0
 
       -- everything up to updfr_off is off-limits
       -- stack1 contains updfr_off, plus everything we need to save
-      (stack1, assignments) = allocate updfr_off live stack0
+      (stack1, assignments) = allocate dflags updfr_off live stack0
 
       -- And the Sp at the continuation is:
       --   sm_sp stack1 + ret_args
@@ -527,9 +559,9 @@ setupStackFrame lbl liveness updfr_off ret_args stack0
 -- So to fix this we want to set up the stack frame before the
 -- conditional jump.  How do we know when to do this, and when it is
 -- safe?  The basic idea is, when we see the assignment
--- 
+--
 --   Sp[young(L)] = L
--- 
+--
 -- we know that
 --   * we are definitely heading for L
 --   * there can be no more reads from another stack area, because young(L)
@@ -563,11 +595,12 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
 -- on the stack and return the new StackMap and the assignments to do
 -- the saving.
 --
-allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O])
-allocate ret_off live stackmap@StackMap{ sm_sp = sp0
-                                       , sm_regs = regs0 }
+allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
+         -> (StackMap, [CmmNode O O])
+allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
+                                              , sm_regs = regs0 }
  =
-  pprTrace "allocate" (ppr live $$ ppr stackmap) $
+  -- pprTrace "allocate" (ppr live $$ ppr stackmap) $
 
    -- we only have to save regs that are not already in a slot
    let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
@@ -576,37 +609,37 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
 
    -- make a map of the stack
    let stack = reverse $ Array.elems $
-               accumArray (\_ x -> x) Empty (1, toWords (max sp0 ret_off)) $
+               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
                  ret_words ++ live_words
             where ret_words =
                    [ (x, Occupied)
-                   | x <- [ 1 .. toWords ret_off] ]
+                   | x <- [ 1 .. toWords dflags ret_off] ]
                   live_words =
-                   [ (toWords x, Occupied)
+                   [ (toWords dflags x, Occupied)
                    | (r,off) <- eltsUFM regs1,
-                     let w = localRegBytes r,
-                     x <- [ off, off-wORD_SIZE .. off - w + 1] ]
+                     let w = localRegBytes dflags r,
+                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
    in
 
    -- Pass over the stack: find slots to save all the new live variables,
    -- choosing the oldest slots first (hence a foldr).
    let
        save slot ([], stack, n, assigs, regs) -- no more regs to save
-          = ([], slot:stack, n `plusW` 1, assigs, regs)
+          = ([], slot:stack, plusW dflags n 1, assigs, regs)
        save slot (to_save, stack, n, assigs, regs)
           = case slot of
-               Occupied ->  (to_save, Occupied:stack, n `plusW` 1, assigs, regs)
+               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
                Empty
                  | Just (stack', r, to_save') <-
                        select_save to_save (slot:stack)
                  -> let assig = CmmStore (CmmStackSlot Old n')
                                          (CmmReg (CmmLocal r))
-                        n' = n `plusW` 1
+                        n' = plusW dflags n 1
                    in
                         (to_save', stack', n', assig : assigs, (r,(r,n')):regs)
 
                  | otherwise
-                 -> (to_save, slot:stack, n `plusW` 1, assigs, regs)
+                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
 
        -- we should do better here: right now we'll fit the smallest first,
        -- but it would make more sense to fit the biggest first.
@@ -619,7 +652,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
                  = Just (replicate words Occupied ++ rest, r, rs++no_fit)
                  | otherwise
                  = go rs (r:no_fit)
-                 where words = localRegWords r
+                 where words = localRegWords dflags r
 
        -- fill in empty slots as much as possible
        (still_to_save, save_stack, n, save_assigs, save_regs)
@@ -632,14 +665,14 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
               push r (n, assigs, regs)
                 = (n', assig : assigs, (r,(r,n')) : regs)
                 where
-                  n' = n + localRegBytes r
+                  n' = n + localRegBytes dflags r
                   assig = CmmStore (CmmStackSlot Old n')
                                    (CmmReg (CmmLocal r))
 
        trim_sp
           | not (null push_regs) = push_sp
           | otherwise
-          = n `plusW` (- length (takeWhile isEmpty save_stack))
+          = plusW dflags n (- length (takeWhile isEmpty save_stack))
 
        final_regs = regs1 `addListToUFM` push_regs
                           `addListToUFM` save_regs
@@ -648,7 +681,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
   -- XXX should be an assert
    if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
 
-   if (trim_sp .&. (wORD_SIZE - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
 
    ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
    , push_assigs ++ save_assigs )
@@ -670,7 +703,8 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
 -- middle_post, because the Sp adjustment intervenes.
 --
 manifestSp
-   :: BlockEnv StackMap  -- StackMaps for other blocks
+   :: DynFlags
+   -> BlockEnv StackMap  -- StackMaps for other blocks
    -> StackMap           -- StackMap for this block
    -> ByteOff            -- Sp on entry to the block
    -> ByteOff            -- SpHigh
@@ -681,17 +715,17 @@ manifestSp
    -> [CmmBlock]         -- new blocks
    -> [CmmBlock]         -- final blocks with Sp manifest
 
-manifestSp stackmaps stack0 sp0 sp_high
+manifestSp dflags stackmaps stack0 sp0 sp_high
            first middle_pre sp_off last fixup_blocks
   = final_block : fixup_blocks'
   where
     area_off = getAreaOff stackmaps
 
     adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
-    adj_pre_sp  = mapExpDeep (areaToSp sp0            sp_high area_off)
-    adj_post_sp = mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off)
+    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
+    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
 
-    final_middle = maybeAddSpAdj sp_off $
+    final_middle = maybeAddSpAdj dflags sp_off $
                    blockFromList $
                    map adj_pre_sp $
                    elimStackStores stack0 stackmaps area_off $
@@ -701,7 +735,7 @@ manifestSp stackmaps stack0 sp0 sp_high
 
     final_block   = blockJoin first final_middle final_last
 
-    fixup_blocks' = map (blockMapNodes3 (id, adj_post_sp, id)) fixup_blocks
+    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
 
 
 getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
@@ -712,10 +746,10 @@ getAreaOff stackmaps (Young l) =
     Nothing -> pprPanic "getAreaOff" (ppr l)
 
 
-maybeAddSpAdj :: ByteOff -> Block CmmNode O O -> Block CmmNode O O
-maybeAddSpAdj 0      block = block
-maybeAddSpAdj sp_off block
-   = block `blockSnoc` CmmAssign spReg (cmmOffset (CmmReg spReg) sp_off)
+maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
+maybeAddSpAdj _      0      block = block
+maybeAddSpAdj dflags sp_off block
+   = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
 
 
 {-
@@ -735,16 +769,16 @@ arguments.
    to be Sp + Sp(L) - Sp(L')
 -}
 
-areaToSp :: ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
-areaToSp sp_old _sp_hwm area_off (CmmStackSlot area n) =
-  cmmOffset (CmmReg spReg) (sp_old - area_off area - n)
-areaToSp _ sp_hwm _ (CmmLit CmmHighStackMark) = CmmLit (mkIntCLit sp_hwm)
-areaToSp _ _ _ (CmmMachOp (MO_U_Lt _)  -- Note [null stack check]
-                      [CmmMachOp (MO_Sub _)
-                              [ CmmReg (CmmGlobal Sp)
-                              , CmmLit (CmmInt 0 _)],
-                       CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
-areaToSp _ _ _ other = other
+areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) =
+  cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
+areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr dflags sp_hwm
+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _)  -- Note [null stack check]
+                          [CmmMachOp (MO_Sub _)
+                                  [ CmmReg (CmmGlobal Sp)
+                                  , CmmLit (CmmInt 0 _)],
+                           CmmReg (CmmGlobal SpLim)]) = zeroExpr dflags
+areaToSp _ _ _ other = other
 
 -- -----------------------------------------------------------------------------
 -- Note [null stack check]
@@ -795,7 +829,8 @@ elimStackStores stackmap stackmaps area_off nodes
          CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
             | Just (_,off) <- lookupUFM (sm_regs stackmap) r
             , area_off area + m == off
-            -> pprTrace "eliminated a node!" (ppr r) $ go stackmap ns
+            -> -- pprTrace "eliminated a node!" (ppr r) $
+               go stackmap ns
          _otherwise
             -> n : go (procMiddle stackmaps n stackmap) ns
 
@@ -804,31 +839,30 @@ elimStackStores stackmap stackmaps area_off nodes
 -- Update info tables to include stack liveness
 
 
-setInfoTableStackMap :: BlockEnv StackMap -> CmmDecl -> CmmDecl
-setInfoTableStackMap stackmaps
-    (CmmProc top_info@TopInfo{..} l g@CmmGraph{g_entry = eid})
-  = CmmProc top_info{ info_tbl = fix_info info_tbl } l g
+setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl
+setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
+  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
   where
-    fix_info info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
-       info_tbl { cit_rep = StackRep (get_liveness eid) }
-    fix_info other = other
+    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
+       info_tbl { cit_rep = StackRep (get_liveness lbl) }
+    fix_info other = other
 
     get_liveness :: BlockId -> Liveness
     get_liveness lbl
       = case mapLookup lbl stackmaps of
-          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl)
-          Just sm -> stackMapToLiveness sm
+          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
+          Just sm -> stackMapToLiveness dflags sm
 
-setInfoTableStackMap _ d = d
+setInfoTableStackMap _ d = d
 
 
-stackMapToLiveness :: StackMap -> Liveness
-stackMapToLiveness StackMap{..} =
+stackMapToLiveness :: DynFlags -> StackMap -> Liveness
+stackMapToLiveness dflags StackMap{..} =
    reverse $ Array.elems $
-        accumArray (\_ x -> x) True (toWords sm_ret_off + 1,
-                                     toWords (sm_sp - sm_args)) live_words
+        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
+                                     toWords dflags (sm_sp - sm_args)) live_words
    where
-     live_words =  [ (toWords off, False)
+     live_words =  [ (toWords dflags off, False)
                    | (r,off) <- eltsUFM sm_regs, isGcPtrType (localRegType r) ]
 
 
@@ -836,7 +870,7 @@ stackMapToLiveness StackMap{..} =
 -- Lowering safe foreign calls
 
 {-
-Note [lower safe foreign calls]
+Note [Lower safe foreign calls]
 
 We start with
 
@@ -859,50 +893,56 @@ live across the call.  Our job now is to expand the call so we get
  | BaseReg = resumeThread(token)
  | LOAD_THREAD_STATE()
  | R1 = r  -- copyOut
- | jump L1
+ | jump Sp[0]
  '-----------------------
  L1:
    r = R1 -- copyIn, inserted by mkSafeCall
    ...
 
 Note the copyOut, which saves the results in the places that L1 is
-expecting them (see Note {safe foreign call convention]).
+expecting them (see Note {safe foreign call convention]). Note also
+that safe foreign call is replace by an unsafe one in the Cmm graph.
 -}
 
-lowerSafeForeignCall :: CmmBlock -> UniqSM CmmBlock
-lowerSafeForeignCall block
+lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
+lowerSafeForeignCall dflags block
   | (entry, middle, CmmForeignCall { .. }) <- blockSplit block
   = do
     -- Both 'id' and 'new_base' are KindNonPtr because they're
     -- RTS-only objects and are not subject to garbage collection
-    id <- newTemp bWord
-    new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
-    let (caller_save, caller_load) = callerSaveVolatileRegs
-    load_tso <- newTemp gcWord
-    load_stack <- newTemp gcWord
-    let suspend = saveThreadState <*>
+    id <- newTemp (bWord dflags)
+    new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
+    load_tso <- newTemp (gcWord dflags)
+    load_stack <- newTemp (gcWord dflags)
+    let suspend = saveThreadState dflags <*>
                   caller_save <*>
-                  mkMiddle (callSuspendThread id intrbl)
+                  mkMiddle (callSuspendThread dflags id intrbl)
         midCall = mkUnsafeCall tgt res args
         resume  = mkMiddle (callResumeThread new_base id) <*>
                   -- Assign the result to BaseReg: we
                   -- might now have a different Capability!
                   mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
                   caller_load <*>
-                  loadThreadState load_tso load_stack
-        -- Note: The successor must be a procpoint, and we have already split,
-        --       so we use a jump, not a branch.
-        succLbl = CmmLit (CmmLabel (infoTblLbl succ))
-
-        (ret_args, copyout) = copyOutOflow NativeReturn Jump (Young succ)
-                                           (map (CmmReg . CmmLocal) res)
-                                           updfr (0, [])
-
-        jump = CmmCall { cml_target   = succLbl
-                       , cml_cont     = Just succ
-                       , cml_args     = widthInBytes wordWidth
-                       , cml_ret_args = ret_args
-                       , cml_ret_off  = updfr }
+                  loadThreadState dflags load_tso load_stack
+
+        (_, regs, copyout) =
+             copyOutOflow dflags NativeReturn Jump (Young succ)
+                            (map (CmmReg . CmmLocal) res)
+                            ret_off []
+
+        -- NB. after resumeThread returns, the top-of-stack probably contains
+        -- the stack frame for succ, but it might not: if the current thread
+        -- received an exception during the call, then the stack might be
+        -- different.  Hence we continue by jumping to the top stack frame,
+        -- not by jumping to succ.
+        jump = CmmCall { cml_target    = entryCode dflags $
+                                         CmmLoad (CmmReg spReg) (bWord dflags)
+                       , cml_cont      = Just succ
+                       , cml_args_regs = regs
+                       , cml_args      = widthInBytes (wordWidth dflags)
+                       , cml_ret_args  = ret_args
+                       , cml_ret_off   = ret_off }
 
     graph' <- lgraphOfAGraph $ suspend <*>
                                midCall <*>
@@ -920,29 +960,29 @@ lowerSafeForeignCall block
 
 
 foreignLbl :: FastString -> CmmExpr
-foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
 
 newTemp :: CmmType -> UniqSM LocalReg
 newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
 
-callSuspendThread :: LocalReg -> Bool -> CmmNode O O
-callSuspendThread id intrbl =
+callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
+callSuspendThread dflags id intrbl =
   CmmUnsafeForeignCall
        (ForeignTarget (foreignLbl (fsLit "suspendThread"))
-             (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
-       [id] [CmmReg (CmmGlobal BaseReg), CmmLit (mkIntCLit (fromEnum intrbl))]
+        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
+       [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
 
 callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
 callResumeThread new_base id =
   CmmUnsafeForeignCall
        (ForeignTarget (foreignLbl (fsLit "resumeThread"))
-            (ForeignConvention CCallConv [AddrHint] [AddrHint]))
+            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
        [new_base] [CmmReg (CmmLocal id)]
 
 -- -----------------------------------------------------------------------------
 
-plusW :: ByteOff -> WordOff -> ByteOff
-plusW b w = b + w * wORD_SIZE
+plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
+plusW dflags b w = b + w * wORD_SIZE dflags
 
 dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
 dropEmpty 0 ss           = Just ss
@@ -953,14 +993,15 @@ isEmpty :: StackSlot -> Bool
 isEmpty Empty = True
 isEmpty _ = False
 
-localRegBytes :: LocalReg -> ByteOff
-localRegBytes r = roundUpToWords (widthInBytes (typeWidth (localRegType r)))
+localRegBytes :: DynFlags -> LocalReg -> ByteOff
+localRegBytes dflags r
+    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
 
-localRegWords :: LocalReg -> WordOff
-localRegWords = toWords . localRegBytes
+localRegWords :: DynFlags -> LocalReg -> WordOff
+localRegWords dflags = toWords dflags . localRegBytes dflags
 
-toWords :: ByteOff -> WordOff
-toWords x = x `quot` wORD_SIZE
+toWords :: DynFlags -> ByteOff -> WordOff
+toWords dflags x = x `quot` wORD_SIZE dflags
 
 
 insertReloads :: StackMap -> [CmmNode O O]
@@ -973,73 +1014,3 @@ insertReloads stackmap =
 
 stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
 stackSlotRegs sm = eltsUFM (sm_regs sm)
-
--- -----------------------------------------------------------------------------
-
--- If we do this *before* stack layout, we might be able to avoid
--- saving some things across calls/procpoints.
---
--- *but*, that will invalidate the liveness analysis, and we'll have
--- to re-do it.
-
-cmmSink :: CmmGraph -> FuelUniqSM CmmGraph
-cmmSink graph = do
-  let liveness = cmmLiveness graph
-  return $ cmmSink' liveness graph
-
-cmmSink' :: BlockEnv CmmLive -> CmmGraph -> CmmGraph
-cmmSink' liveness graph
-  = ofBlockList (g_entry graph) $ sink mapEmpty $ postorderDfs graph
-  where
-
-  sink :: BlockEnv [(LocalReg, CmmExpr)] -> [CmmBlock] -> [CmmBlock]
-  sink _ [] = []
-  sink sunk (b:bs) =
-    pprTrace "sink" (ppr l) $
-    blockJoin first final_middle last : sink sunk' bs
-    where
-      l = entryLabel b
-      (first, middle, last) = blockSplit b
-      (middle', assigs) = walk (blockToList middle) emptyBlock
-                               (mapFindWithDefault [] l sunk)
-
-      (dropped_last, assigs') = partition (`conflictsWithLast` last) assigs
-
-      final_middle = foldl blockSnoc middle' (toNodes dropped_last)
-
-      sunk' = mapUnion sunk $
-                 mapFromList [ (l, filt assigs' (getLive l))
-                             | l <- successors last ]
-           where
-               getLive l = mapFindWithDefault Set.empty l liveness
-               filt as live = [ (r,e) | (r,e) <- as, r `Set.member` live ]
-
-
-walk :: [CmmNode O O] -> Block CmmNode O O -> [(LocalReg, CmmExpr)]
-     -> (Block CmmNode O O, [(LocalReg, CmmExpr)])
-
-walk []     acc as = (acc, as)
-walk (n:ns) acc as
-  | Just a <- collect_it  = walk ns acc (a:as)
-  | otherwise             = walk ns (foldr (flip blockSnoc) acc (n:drop_nodes)) as'
-  where
-    collect_it = case n of
-                   CmmAssign (CmmLocal r) e@(CmmReg (CmmGlobal _)) -> Just (r,e)
---                   CmmAssign (CmmLocal r) e@(CmmLoad addr _) |
---                      foldRegsUsed (\b r -> False) True addr -> Just (r,e)
-                   _ -> Nothing
-
-    drop_nodes = toNodes dropped
-    (dropped, as') = partition should_drop as
-       where should_drop a = a `conflicts` n
-
-toNodes as = [ CmmAssign (CmmLocal r) rhs | (r,rhs) <- as ]
-
--- We only sink "r = G" assignments right now, so conflicts is very simple:
-(r, rhs) `conflicts` CmmAssign reg  _  | reg `regUsedIn` rhs = True
---(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True
-(r, _)   `conflicts` node
-  = foldRegsUsed (\b r' -> r == r' || b) False node
-
-(r, _) `conflictsWithLast` node
-  = foldRegsUsed (\b r' -> r == r' || b) False node