Compare revisions

Ben Gamari · Ben Gamari · Ben Gamari · Ben Gamari · Ben Gamari · Ben Gamari
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -4,6 +4,7 @@
 {- BlockId module should probably go away completely, being superseded by Label -}
 module BlockId
  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+  , newBlockId
  , BlockSet, BlockEnv
  , IsSet(..), setInsertList, setDeleteList, setUnions
  , IsMap(..), mapInsertList, mapDeleteList, mapUnions
@@ -16,6 +17,7 @@ import IdInfo
 import Name
 import Outputable
 import Unique
+import UniqSupply
 import Compiler.Hoopl as Hoopl hiding (Unique)
 import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)
@@ -43,6 +45,9 @@ instance Outputable BlockId where
 mkBlockId :: Unique -> BlockId
 mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
 retPtLbl :: BlockId -> CLabel
 retPtLbl label = mkReturnPtLabel $ getUnique label

--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -132,7 +132,7 @@ hash_block block =
        hash_node :: CmmNode O x -> Word32
        hash_node n | dont_care n = 0 -- don't care
-        hash_node (CmmUnwind _ e) = hash_e e
+        hash_node (CmmUnwind _ regs) = hash_list hash_e $ map snd regs
        hash_node (CmmAssign r e) = hash_reg r + hash_e e
        hash_node (CmmStore e e') = hash_e e + hash_e e'
        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as

--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -4,7 +4,7 @@ module CmmLayoutStack (
  ) where
 import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
-import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
+import StgCmmForeign    ( saveThreadState, loadThreadState, InitialSp ) -- XXX layering violation
 import BasicTypes
 import Cmm
@@ -19,6 +19,7 @@ import CmmProcPoint
 import SMRep
 import Hoopl
 import UniqSupply
+import StgCmmUtils      ( newTemp )
 import Maybes
 import UniqFM
 import Util
@@ -27,11 +28,11 @@ import DynFlags
 import FastString
 import Outputable hiding ( isEmpty )
 import qualified Data.Set as Set
+import Control.Monad ((<=<))
 import Control.Monad.Fix
 import Data.Array as Array
 import Data.Bits
 import Data.List (nub)
-import Control.Monad (liftM)
 import Prelude hiding ((<*>))
@@ -275,10 +276,10 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
       --
       let middle_pre = blockToList $ foldl blockSnoc middle1 middle2
-           final_blocks = manifestSp dflags final_stackmaps stack0 sp0 final_sp_high entry0
+       final_blocks <- manifestSp dflags final_stackmaps stack0 sp0 final_sp_high entry0
-                              middle_pre sp_off last1 fixup_blocks
+                                  middle_pre sp_off last1 fixup_blocks
-           acc_stackmaps' = mapUnion acc_stackmaps out
+       let acc_stackmaps' = mapUnion acc_stackmaps out
           -- If this block jumps to the GC, then we do not take its
           -- stack usage into account for the high-water mark.
@@ -525,10 +526,11 @@ makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
 makeFixupBlock dflags sp0 l stack tscope assigs
  | null assigs && sp0 == sm_sp stack = return (l, [])
  | otherwise = do
-    tmp_lbl <- liftM mkBlockId $ getUniqueM
+    tmp_lbl <- newBlockId
    let sp_off = sp0 - sm_sp stack
-        block = blockJoin (CmmEntry tmp_lbl tscope)
+    fixed_up <- maybeAddSpAdj dflags sp0 sp_off (blockFromList assigs)
-                          (maybeAddSpAdj dflags sp_off (blockFromList assigs))
+    let block = blockJoin (CmmEntry tmp_lbl tscope)
+                          fixed_up
                          (CmmBranch l)
    return (tmp_lbl, [block])
@@ -780,36 +782,38 @@ manifestSp
   -> ByteOff            -- sp_off
   -> CmmNode O C        -- last node
   -> [CmmBlock]         -- new blocks
-   -> [CmmBlock]         -- final blocks with Sp manifest
+   -> UniqSM [CmmBlock]  -- final blocks with Sp manifest
 manifestSp dflags stackmaps stack0 sp0 sp_high
           first middle_pre sp_off last fixup_blocks
-  = final_block : fixup_blocks'
+  = do
-  where
+    let -- Add unwind pseudo-instructions to document Sp level for debugging
-    area_off = getAreaOff stackmaps
+        add_unwind_info block
+          | debugLevel dflags > 0 = do lbl <- newBlockId
+                                       pure $ CmmUnwind (NewLabel lbl) [(Sp, sp_unwind)] : block
+          | otherwise             = pure block
+        sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 - wORD_SIZE dflags)
-    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
+    final_middle <- maybeAddSpAdj dflags sp0 sp_off <=<
-    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
+                    pure . blockFromList <=<
-    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
+                    add_unwind_info $
+                    map adj_pre_sp $
+                    elimStackStores stack0 stackmaps area_off $
+                    middle_pre
-    -- Add unwind pseudo-instructions to document Sp level for debugging
+    let final_last    = optStackCheck (adj_post_sp last)
-    add_unwind_info block
-      | debugLevel dflags > 0 = CmmUnwind Sp sp_unwind : block
-      | otherwise             = block
-    sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 - wORD_SIZE dflags)
-    final_middle = maybeAddSpAdj dflags sp_off $
+        final_block   = blockJoin first final_middle final_last
-                   blockFromList $
-                   add_unwind_info $
-                   map adj_pre_sp $
-                   elimStackStores stack0 stackmaps area_off $
-                   middle_pre
-    final_last    = optStackCheck (adj_post_sp last)
+        fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
-    final_block   = blockJoin first final_middle final_last
+    pure $ final_block : fixup_blocks'
+  where
+    area_off = getAreaOff stackmaps
-    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
+    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
+    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
+    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
 getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
@@ -820,10 +824,19 @@ getAreaOff stackmaps (Young l) =
    Nothing -> pprPanic "getAreaOff" (ppr l)
-maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
+maybeAddSpAdj :: DynFlags
-maybeAddSpAdj _      0      block = block
+              -> ByteOff            -- ^ Sp on entry to the block
-maybeAddSpAdj dflags sp_off block
+              -> ByteOff            -- ^ sp_off
-   = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
+              -> Block CmmNode O O  -- ^ the block to append the adjustment to
+              -> UniqSM (Block CmmNode O O)
+maybeAddSpAdj _      _   0      block = pure block
+maybeAddSpAdj dflags sp0 sp_off block
+   = do
+     lbl <- newBlockId
+     pure $ block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
+                  `blockSnoc` CmmUnwind (NewLabel lbl)
+                                  [(Sp, cmmRegOff (CmmGlobal Sp)
+                                                  (sp0 - wORD_SIZE dflags - sp_off))]
 {-
@@ -989,6 +1002,31 @@ expecting them (see Note {safe foreign call convention]). Note also
 that safe foreign call is replace by an unsafe one in the Cmm graph.
 -}
+findLastUnwinding :: GlobalReg -> CmmBlock -> Maybe CmmExpr
+findLastUnwinding reg block =
+    case mapMaybe isUnwind $ blockToList mid of
+      [] -> Nothing
+      xs -> Just $ last xs
+  where
+    (_,mid,_) = blockSplit block
+    isUnwind (CmmUnwind _ regs) = lookup reg regs
+    isUnwind _                  = Nothing
+-- | @substReg reg expr subst@ replaces all occurrences of @CmmReg reg@ in
+-- @expr@ with @subst@.
+substReg :: DynFlags -> CmmReg -> CmmExpr -> CmmExpr -> CmmExpr
+substReg dflags reg = go
+  where
+    go (CmmReg reg')        subst
+      | reg == reg'               = subst
+    go (CmmRegOff reg' off) subst
+      | reg == reg'               =
+        CmmMachOp (MO_Add rep) [subst, CmmLit (CmmInt (fromIntegral off) rep)]
+      where rep = typeWidth (cmmRegType dflags reg')
+    go (CmmLoad e ty)       subst = CmmLoad (go e subst) ty
+    go (CmmMachOp op es)    subst = CmmMachOp op (map (flip go subst) es)
+    go other                _     = other
 lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
 lowerSafeForeignCall dflags block
  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
@@ -998,12 +1036,12 @@ lowerSafeForeignCall dflags block
    id <- newTemp (bWord dflags)
    new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
-    load_stack <- newTemp (gcWord dflags)
+    let initialSp = findLastUnwinding Sp block
-    tso <- newTemp (gcWord dflags)
+        substSp :: Maybe InitialSp
-    cn <- newTemp (bWord dflags)
+        substSp = substReg dflags (CmmGlobal Sp) <$> initialSp
-    bdfree <- newTemp (bWord dflags)
+    save_state_code <- saveThreadState dflags substSp
-    bdstart <- newTemp (bWord dflags)
+    load_state_code <- loadThreadState dflags substSp
-    let suspend = saveThreadState dflags tso cn  <*>
+    let suspend = save_state_code  <*>
                  caller_save <*>
                  mkMiddle (callSuspendThread dflags id intrbl)
        midCall = mkUnsafeCall tgt res args
@@ -1012,7 +1050,7 @@ lowerSafeForeignCall dflags block
                  -- might now have a different Capability!
                  mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
                  caller_load <*>
-                  loadThreadState dflags tso load_stack cn bdfree bdstart
+                  load_state_code
        (_, regs, copyout) =
             copyOutOflow dflags NativeReturn Jump (Young succ)
@@ -1050,9 +1088,6 @@ lowerSafeForeignCall dflags block
 foreignLbl :: FastString -> CmmExpr
 foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
-newTemp :: CmmType -> UniqSM LocalReg
-newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
 callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
 callSuspendThread dflags id intrbl =
  CmmUnsafeForeignCall

--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -11,7 +11,7 @@
 module CmmNode (
     CmmNode(..), CmmFormal, CmmActual, CmmTickish,
-     UpdFrameOffset, Convention(..),
+     UpdFrameOffset, NewOrExistingLabel(..), Convention(..),
     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
     CmmReturnInfo(..),
     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
@@ -57,8 +57,9 @@ data CmmNode e x where
    -- instructions for a debugger. This describes how to reconstruct
    -- the "old" value of a register if we want to navigate the stack
    -- up one frame. Having unwind information for @Sp@ will allow the
-    -- debugger to "walk" the stack.
+    -- debugger to "walk" the stack. The label represents a pointer
-  CmmUnwind :: !GlobalReg -> !CmmExpr -> CmmNode O O
+    -- to the current location in the generated code.
+  CmmUnwind :: !NewOrExistingLabel -> [(GlobalReg, CmmExpr)] -> CmmNode O O
  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
    -- Assign to register
@@ -243,6 +244,14 @@ type CmmFormal = LocalReg
 type UpdFrameOffset = ByteOff
+-- | Contains either a new label or reference to an existing label
+data NewOrExistingLabel = NewLabel !Label | ExistingLabel !Label
+                        deriving (Eq)
+instance Outputable NewOrExistingLabel where
+  ppr (NewLabel lbl) = text "NewLabel" <+> ppr lbl
+  ppr (ExistingLabel lbl) = text "ExistingLabel" <+> ppr lbl
 -- | A convention maps a list of values (function arguments or return
 -- values) to registers or stack locations.
 data Convention
@@ -460,7 +469,7 @@ mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
 mapExp _ f@(CmmEntry{})                          = f
 mapExp _ m@(CmmComment _)                        = m
 mapExp _ m@(CmmTick _)                           = m
-mapExp f   (CmmUnwind r e)                       = CmmUnwind r (f e)
+mapExp f   (CmmUnwind lbl regs)                  = CmmUnwind lbl (map (fmap f) regs)
 mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
 mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
 mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
@@ -491,7 +500,7 @@ mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
 mapExpM _ (CmmEntry{})              = Nothing
 mapExpM _ (CmmComment _)            = Nothing
 mapExpM _ (CmmTick _)               = Nothing
-mapExpM f (CmmUnwind r e)           = CmmUnwind r `fmap` f e
+mapExpM f (CmmUnwind lbl regs)      = CmmUnwind lbl `fmap` mapM (\(r,e) -> f e >>= \e' -> pure (r,e')) regs
 mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
 mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
 mapExpM _ (CmmBranch _)             = Nothing
@@ -544,7 +553,7 @@ foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
 foldExp _ (CmmEntry {}) z                         = z
 foldExp _ (CmmComment {}) z                       = z
 foldExp _ (CmmTick {}) z                          = z
-foldExp f (CmmUnwind _ e) z                       = f e z
+foldExp f (CmmUnwind _ regs) z                    = foldr f z $ map snd regs
 foldExp f (CmmAssign _ e) z                       = f e z
 foldExp f (CmmStore addr e) z                     = f addr $ f e z
 foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as

--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -635,8 +635,15 @@ stmt    :: { CmmParse () }
                { pushStackFrame $3 $5 }
        | 'reserve' expr '=' lreg maybe_body
                { reserveStackFrame $2 $4 $5 }
-        | 'unwind' GLOBALREG '=' expr
+        | 'unwind' unwind_regs ';'
-                { $4 >>= code . emitUnwind $2 }
+                { $2 >>= code . emitUnwind }
+unwind_regs
+        :: { CmmParse [(GlobalReg, CmmExpr)] }
+        : GLOBALREG '=' expr ',' unwind_regs
+                { do e <- $3; rest <- $5; return (($1, e) : rest) }
+        | GLOBALREG '=' expr
+                { do e <- $3; return [($1, e)] }
 foreignLabel     :: { CmmParse CmmExpr }
        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }

--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -12,15 +12,18 @@
 module Debug (
  DebugBlock(..), dblIsEntry,
-  UnwindTable, UnwindExpr(..),
  cmmDebugGen,
  cmmDebugLabels,
  cmmDebugLink,
-  debugToMap
+  debugToMap,
+  -- * Unwinding information
+  UnwindTable, UnwindPoints(..), UnwindExpr(..),
+  addDefaultUnwindings
  ) where
-import BlockId         ( blockLbl )
+import BlockId
 import CLabel
 import Cmm
 import CmmUtils
@@ -32,6 +35,7 @@ import PprCore         ()
 import PprCmmExpr      ( pprExpr )
 import SrcLoc
 import Util
+import Unique
 import Compiler.Hoopl
@@ -56,7 +60,7 @@ data DebugBlock =
  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to
                                   -- other blocks. @Nothing@ means
                                   -- the block was optimized out
-  , dblUnwind     :: !UnwindTable  -- ^ Unwind information
+  , dblUnwind     :: UnwindPoints  -- ^ Unwind information
  , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks
  }
@@ -74,14 +78,17 @@ instance Outputable DebugBlock where
            (maybe empty ppr (dblSourceTick blk)) <+>
            (maybe (text "removed") ((text "pos " <>) . ppr)
                   (dblPosition blk)) <+>
-            pprUwMap (dblUnwind blk) $$
+            pprUwPts (dblUnwind blk) $$
            (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
-    where pprUw (g, expr) = ppr g <> char '=' <> ppr expr
+    where pprUwPts (UnwindPoints pts) = hsep $ punctuate comma $ map pprUwPt pts
-          pprUwMap = braces . hsep . punctuate comma . map pprUw . Map.toList
+          pprUwPt (lbl, uws) =
+            braces $ ppr lbl<>colon
+            <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
+          pprUw (g, expr) = ppr g <> char '=' <> ppr expr
 -- | Intermediate data structure holding debug-relevant context information
 -- about a block.
-type BlockContext = (CmmBlock, RawCmmDecl, UnwindTable)
+type BlockContext = (CmmBlock, RawCmmDecl, UnwindPoints)
 -- | Extract debug data from a group of procedures. We will prefer
 -- source notes that come from the given module (presumably the module
@@ -151,6 +158,8 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
              nested = fromMaybe [] $ Map.lookup scope scopeMap
              childs = map (mkBlock False) (tail bctxs) ++
                       map (blocksForScope stick) nested
+              mkBlock :: Bool -> BlockContext -> DebugBlock
              mkBlock top (block, prc, unwind)
                = DebugBlock { dblProcedure    = g_entry graph
                             , dblLabel        = label
@@ -194,24 +203,35 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
 -- lacking.
 blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
 blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
-  where walkProc CmmData{}                 m = m
+  where walkProc :: RawCmmDecl
+                 -> Map.Map CmmTickScope [BlockContext]
+                 -> Map.Map CmmTickScope [BlockContext]
+        walkProc CmmData{}                 m = m
        walkProc prc@(CmmProc _ _ _ graph) m
          | mapNull blocks = m
          | otherwise      = snd $ walkBlock prc entry Map.empty (emptyLbls, m)
          where blocks = toBlockMap graph
                entry  = [mapFind (g_entry graph) blocks]
                emptyLbls = setEmpty :: LabelSet
-        walkBlock _   []             _      c            = c
-        walkBlock prc (block:blocks) unwind (visited, m)
+        walkBlock :: RawCmmDecl -> [Block CmmNode C C]
+                  -> UnwindTable     -- ^ unwinding table of predecessor block
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+        walkBlock _   []             _          c            = c
+        walkBlock prc (block:blocks) predUnwind (visited, m)
          | lbl `setMember` visited
-          = walkBlock prc blocks unwind (visited, m)
+          = walkBlock prc blocks predUnwind (visited, m)
          | otherwise
-          = walkBlock prc blocks unwind $
+          = walkBlock prc blocks predUnwind $
-            walkBlock prc succs unwind'
+            walkBlock prc succs succUnwind
              (lbl `setInsert` visited,
               insertMulti scope (block, prc, unwind') m)
          where CmmEntry lbl scope = firstNode block
-                unwind' = extractUnwind block `Map.union` unwind
+                -- fold in unwinding information from predecessor block
+                unwind' = addDefaultUnwindings predUnwind
+                        $ extractUnwindTables block
+                succUnwind = lastUnwindingPoint unwind'
                (CmmProc _ _ _ graph) = prc
                succs = map (flip mapFind (toBlockMap graph))
                            (successors (lastNode block))
@@ -251,13 +271,23 @@ debugToMap = mapUnions . map go
 -- | Maps registers to expressions that yield their "old" values
 -- further up the stack. Most interesting for the stack pointer Sp,
-- but might be useful to document saved registers, too.
+-- but might be useful to document saved registers, too. The 'Label'
+-- gives the label in the generated block that this table is associated
+-- with.
 type UnwindTable = Map.Map GlobalReg UnwindExpr
+-- | A sequence of locations within a block annotated with unwinding tables.
+-- This list is sorted in the order that the labels occur in the block.
+newtype UnwindPoints = UnwindPoints [(CLabel, UnwindTable)]
+instance Outputable UnwindPoints where
+  ppr (UnwindPoints pts) = ppr pts
 -- | Expressions, used for unwind information
 data UnwindExpr = UwConst Int                   -- ^ literal value
                | UwReg GlobalReg Int           -- ^ register plus offset
                | UwDeref UnwindExpr            -- ^ pointer dereferencing
+                | UwLabel CLabel
                | UwPlus UnwindExpr UnwindExpr
                | UwMinus UnwindExpr UnwindExpr
                | UwTimes UnwindExpr UnwindExpr
@@ -268,6 +298,7 @@ instance Outputable UnwindExpr where
  pprPrec _ (UwReg g 0)     = ppr g
  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e
+  pprPrec _ (UwLabel l)     = pprPrec 3 l
  pprPrec p (UwPlus e0 e1)  | p <= 0
                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
  pprPrec p (UwMinus e0 e1) | p <= 0
@@ -276,22 +307,39 @@ instance Outputable UnwindExpr where
                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
  pprPrec _ other           = parens (pprPrec 0 other)
-extractUnwind :: CmmBlock -> UnwindTable
-extractUnwind b = go $ blockToList mid
+-- | @addDefaultUnwindings uws points@ adds default unwinding information
-  where (_, mid, _) = blockSplit b
+-- from @uws@ to @points@.
-        go :: [CmmNode O O] -> UnwindTable
+addDefaultUnwindings :: UnwindTable -> UnwindPoints -> UnwindPoints
-        go []       = Map.empty
+addDefaultUnwindings uws (UnwindPoints pts) =
-        go (x : xs) = case x of
+    UnwindPoints $ map (fmap (`Map.union` uws)) pts
-          CmmUnwind g so -> Map.insert g (toUnwindExpr so) $! go xs
-          CmmTick {}     -> go xs
+-- | The unwinding table from the last unwinding point in a block
-          _other         -> Map.empty
+lastUnwindingPoint :: UnwindPoints -> UnwindTable
-                            -- TODO: Unwind statements after actual instructions
+lastUnwindingPoint (UnwindPoints pts) = snd $ last pts
+extractUnwindTables :: CmmBlock -> UnwindPoints
+extractUnwindTables b =
+    UnwindPoints $ mapMaybe nodeToUnwind $ blockToList mid
+  where
+    (_, mid, _) = blockSplit b
+    nodeToUnwind :: CmmNode O O -> Maybe (CLabel, UnwindTable)
+    nodeToUnwind (CmmUnwind lbl regs) =
+        -- FIXME: why a block label if this isn't a block?
+        Just (mkAsmTempLabel (getUnique lbl'), toUnwindExpr <$> Map.fromList regs)
+      where
+        lbl' = case lbl of
+                 NewLabel l      -> l
+                 ExistingLabel l -> l
+    nodeToUnwind _                    = Nothing
 -- | Conversion of Cmm expressions to unwind expressions. We check for
 -- unsupported operator usages and simplify the expression as far as
 -- possible.
 toUnwindExpr :: CmmExpr -> UnwindExpr
 toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)
+toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l
 toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
 toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0
 toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)

--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -7,7 +7,7 @@ module MkGraph
  , lgraphOfAGraph, labelAGraph
  , stackStubExpr
-  , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
+  , mkNop, mkAssign, mkStore, mkUnwind, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
  , mkJumpReturnsTo
  , mkJump, mkJumpExtra
  , mkRawJump
@@ -196,6 +196,9 @@ mkAssign l r  = mkMiddle $ CmmAssign l r
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 mkStore  l r  = mkMiddle $ CmmStore  l r
+mkUnwind     :: NewOrExistingLabel -> GlobalReg -> CmmExpr -> CmmAGraph
+mkUnwind lbl r e = mkMiddle $ CmmUnwind lbl [(r,e)]
 ---------- Control transfer
 mkJump          :: DynFlags -> Convention -> CmmExpr
                -> [CmmActual]

--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -197,7 +197,8 @@ pprNode node = pp_node <+> pp_debug
                   else empty
      -- unwind reg = expr;
-      CmmUnwind r e -> ptext (sLit "unwind ") <> ppr r <+> char '=' <+> ppr e
+      CmmUnwind lbl regs -> ptext (sLit "unwind ") <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
+                            <+> text "//" <+> ppr lbl
      -- reg = expr;
      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi

--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -43,13 +43,13 @@ import Cmm
 import CLabel
 import MkGraph
-- import BasicTypes
 import BlockId
 import DynFlags
 import FastString
 import Module
 import UniqFM
 import Unique
+import UniqSupply
 import Control.Monad (liftM, ap)
@@ -90,6 +90,12 @@ instance Applicative CmmParse where
 instance Monad CmmParse where
  (>>=) = thenExtFC
+instance MonadUnique CmmParse where
+  getUniqueSupplyM = code getUniqueSupplyM
+  getUniqueM = EC $ \_ _ decls -> do
+    u <- getUniqueM
+    return (decls, u)
 instance HasDynFlags CmmParse where
    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
                                   return (d, dflags))
@@ -155,9 +161,6 @@ newLabel name = do
   addLabel name (mkBlockId u)
   return (mkBlockId u)
-newBlockId :: CmmParse BlockId
-newBlockId = code F.newLabelC
 -- | Add add a local function to the environment.
 newFunctionName
        :: FastString   -- ^ name of the function

--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -12,6 +12,7 @@ module StgCmmForeign (
  cgForeignCall,
  emitPrimCall, emitCCall,
  emitForeignCall,     -- For CmmParse
+  InitialSp,
  emitSaveThreadState,
  saveThreadState,
  emitLoadThreadState,
@@ -30,6 +31,7 @@ import StgCmmUtils
 import StgCmmClosure
 import StgCmmLayout
+import BlockId (newBlockId)
 import Cmm
 import CmmUtils
 import MkGraph
@@ -41,6 +43,7 @@ import ForeignCall
 import DynFlags
 import Maybes
 import Outputable
+import UniqSupply
 import BasicTypes
 import Control.Monad
@@ -274,22 +277,41 @@ maybe_assign_temp e = do
 emitSaveThreadState :: FCode ()
 emitSaveThreadState = do
  dflags <- getDynFlags
-  tso <- newTemp (gcWord dflags)
+  code <- saveThreadState dflags Nothing
-  cn <- newTemp (bWord dflags)
+  emit code
-  emit $ saveThreadState dflags tso cn
+-- | Given a @initial :: InitialSp@, @initial (CmmReg sp)@ is an expression
+-- of the current.
+type InitialSp = CmmExpr -> CmmExpr
+-- | Produce code to save the current thread state to @CurrentTSO@
+saveThreadState :: MonadUnique m => DynFlags -> Maybe InitialSp -> m CmmAGraph
+saveThreadState dflags initialSp = do
+  tso <- newTemp (gcWord dflags)
+  close_nursery <- closeNursery dflags tso
+  lbl <- newBlockId
-- saveThreadState must be usable from the stack layout pass, where we
+  pure $ catAGraphs [
-- don't have FCode.  Therefore it takes LocalRegs as arguments, so
-- the caller can create these.
-saveThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
-saveThreadState dflags tso cn =
-  catAGraphs [
    -- tso = CurrentTSO;
    mkAssign (CmmLocal tso) stgCurrentTSO,
    -- tso->stackobj->sp = Sp;
-    mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp,
+    mkStore (cmmOffset dflags
-    closeNursery dflags tso cn,
+                       (CmmLoad (cmmOffset dflags
+                                           (CmmReg (CmmLocal tso))
+                                           (tso_stackobj dflags))
+                                (bWord dflags))
+                       (stack_SP dflags))
+            stgSp,
+    -- unwind Sp = initialSp(tso->stackobj->sp)
+    case initialSp of
+      Just initial | debugLevel dflags > 0 ->
+        let tsoValue =
+              CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags))
+                      (bWord dflags)
+            spValue = cmmOffset dflags tsoValue (stack_SP dflags)
+        in mkUnwind (NewLabel lbl) Sp (initial spValue)
+      _ -> mkNop,
+    close_nursery,
    -- and save the current cost centre stack in the TSO when profiling:
    if gopt Opt_SccProfilingOn dflags then
        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS
@@ -299,14 +321,18 @@ saveThreadState dflags tso cn =
 emitCloseNursery :: FCode ()
 emitCloseNursery = do
  dflags <- getDynFlags
-  tso <- newTemp (gcWord dflags)
+  tso <- newTemp (bWord dflags)
-  cn <- newTemp (bWord dflags)
+  code <- closeNursery dflags tso
-  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
+  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code
-         closeNursery dflags tso cn
+{- |
+@closeNursery dflags tso@ produces code to close the nursery.
+A local register holding the value of @CurrentTSO@ is expected for
+efficiency.
-{-
 Closing the nursery corresponds to the following code:
+@
  tso = CurrentTSO;
  cn = CurrentNuresry;
@@ -318,15 +344,13 @@ Closing the nursery corresponds to the following code:
  // Set cn->free to the next unoccupied word in the block
  cn->free = Hp + WDS(1);
+@
 -}
+closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
-closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
+closeNursery df tso = do
-closeNursery df tso cn =
+  let tsoreg  = CmmLocal tso
-  let
+  cnreg      <- CmmLocal <$> newTemp (bWord df)
-      tsoreg     = CmmLocal tso
+  pure $ catAGraphs [
-      cnreg      = CmmLocal cn
-  in
-  catAGraphs [
    mkAssign cnreg stgCurrentNursery,
    -- CurrentNursery->free = Hp+1;
@@ -350,27 +374,28 @@ closeNursery df tso cn =
 emitLoadThreadState :: FCode ()
 emitLoadThreadState = do
  dflags <- getDynFlags
+  code <- loadThreadState dflags Nothing
+  emit code
+-- | Produce code to load the current thread state from @CurrentTSO@
+loadThreadState :: MonadUnique m => DynFlags -> Maybe (CmmExpr -> CmmExpr) -> m CmmAGraph
+loadThreadState dflags initialSp = do
  tso <- newTemp (gcWord dflags)
  stack <- newTemp (gcWord dflags)
-  cn <- newTemp (bWord dflags)
+  open_nursery <- openNursery dflags tso
-  bdfree <- newTemp (bWord dflags)
+  lbl <- newBlockId
-  bdstart <- newTemp (bWord dflags)
+  pure $ catAGraphs [
-  emit $ loadThreadState dflags tso stack cn bdfree bdstart
-- loadThreadState must be usable from the stack layout pass, where we
-- don't have FCode.  Therefore it takes LocalRegs as arguments, so
-- the caller can create these.
-loadThreadState :: DynFlags
-                -> LocalReg -> LocalReg -> LocalReg -> LocalReg -> LocalReg
-                -> CmmAGraph
-loadThreadState dflags tso stack cn bdfree bdstart =
-  catAGraphs [
    -- tso = CurrentTSO;
    mkAssign (CmmLocal tso) stgCurrentTSO,
    -- stack = tso->stackobj;
    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
    -- Sp = stack->sp;
    mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
+    -- unwind Sp = initialSp(Sp);
+    case initialSp of
+      Just initial | debugLevel dflags > 0 ->
+        mkUnwind (NewLabel lbl) Sp (initial (CmmReg sp))
+      _ -> mkNop,
    -- SpLim = stack->stack + RESERVED_STACK_WORDS;
    mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
                                (rESERVED_STACK_WORDS dflags)),
@@ -378,7 +403,7 @@ loadThreadState dflags tso stack cn bdfree bdstart =
    --   HpAlloc is assumed to be set to non-zero only by a failed
    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
    mkAssign hpAlloc (zeroExpr dflags),
-    openNursery dflags tso cn bdfree bdstart,
+    open_nursery,
    -- and load the current cost centre stack from the TSO when profiling:
    if gopt Opt_SccProfilingOn dflags
       then storeCurCCS
@@ -391,16 +416,17 @@ loadThreadState dflags tso stack cn bdfree bdstart =
 emitOpenNursery :: FCode ()
 emitOpenNursery = do
  dflags <- getDynFlags
-  tso <- newTemp (gcWord dflags)
+  tso <- newTemp (bWord dflags)
-  cn <- newTemp (bWord dflags)
+  code <- openNursery dflags tso
-  bdfree <- newTemp (bWord dflags)
+  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code
-  bdstart <- newTemp (bWord dflags)
-  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
+{- |
-         openNursery dflags tso cn bdfree bdstart
+@openNursery dflags tso@ produces code to open the nursery. A local register
+holding the value of @CurrentTSO@ is expected for efficiency.
-{-
 Opening the nursery corresponds to the following code:
+@
   tso = CurrentTSO;
   cn = CurrentNursery;
   bdfree = CurrentNuresry->free;
@@ -420,23 +446,20 @@ Opening the nursery corresponds to the following code:
   // Set HpLim to the end of the current nursery block (note that this block
   // might be a block group, consisting of several adjacent blocks.
   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+@
 -}
+openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
+openNursery df tso = do
+  let tsoreg =  CmmLocal tso
+  cnreg      <- CmmLocal <$> newTemp (bWord df)
+  bdfreereg  <- CmmLocal <$> newTemp (bWord df)
+  bdstartreg <- CmmLocal <$> newTemp (bWord df)
-openNursery :: DynFlags
-            -> LocalReg -> LocalReg -> LocalReg -> LocalReg
-            -> CmmAGraph
-openNursery df tso cn bdfree bdstart =
-  let
-      tsoreg     = CmmLocal tso
-      cnreg      = CmmLocal cn
-      bdfreereg  = CmmLocal bdfree
-      bdstartreg = CmmLocal bdstart
-  in
  -- These assignments are carefully ordered to reduce register
  -- pressure and generate not completely awful code on x86.  To see
  -- what code we generate, look at the assembly for
  -- stg_returnToStackTop in rts/StgStartup.cmm.
-  catAGraphs [
+  pure $ catAGraphs [
     mkAssign cnreg stgCurrentNursery,
     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),

--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -127,6 +127,12 @@ instance Monad FCode where
 {-# INLINE thenFC #-}
 {-# INLINE returnFC #-}
+instance MonadUnique FCode where
+  getUniqueSupplyM = cgs_uniqs <$> getState
+  getUniqueM = FCode $ \_ st ->
+    let (u, us') = takeUniqFromSupply (cgs_uniqs st)
+    in (# u, st { cgs_uniqs = us' } #)
 initC :: IO CgState
 initC  = do { uniqs <- mkSplitUniqSupply 'c'
            ; return (initCgState uniqs) }
@@ -728,11 +734,12 @@ emitComment _ = return ()
 emitTick :: CmmTickish -> FCode ()
 emitTick = emitCgStmt . CgStmt . CmmTick
-emitUnwind :: GlobalReg -> CmmExpr -> FCode ()
+emitUnwind :: [(GlobalReg, CmmExpr)] -> FCode ()
-emitUnwind g e = do
+emitUnwind regs = do
  dflags <- getDynFlags
-  when (debugLevel dflags > 0) $
+  when (debugLevel dflags > 0) $ do
-     emitCgStmt $ CgStmt $ CmmUnwind g e
+     lbl <- newLabelC
+     emitCgStmt $ CgStmt $ CmmUnwind (NewLabel lbl) regs
 emitAssign :: CmmReg  -> CmmExpr -> FCode ()
 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
@@ -742,8 +749,7 @@ emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
 newLabelC :: FCode BlockId
-newLabelC = do { u <- newUnique
+newLabelC = newBlockId
-               ; return $ mkBlockId u }
 emit :: CmmAGraph -> FCode ()
 emit ag

--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -63,6 +63,7 @@ import Literal
 import Digraph
 import Util
 import Unique
+import UniqSupply (MonadUnique(..))
 import DynFlags
 import FastString
 import Outputable
@@ -345,8 +346,8 @@ assignTemp e = do { dflags <- getDynFlags
                  ; emitAssign (CmmLocal reg) e
                  ; return reg }
-newTemp :: CmmType -> FCode LocalReg
+newTemp :: MonadUnique m => CmmType -> m LocalReg
-newTemp rep = do { uniq <- newUnique
+newTemp rep = do { uniq <- getUniqueM
                 ; return (LocalReg uniq rep) }
 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])

--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -18,6 +18,7 @@ import UniqSupply
 import Dwarf.Constants
 import Dwarf.Types
+import Control.Arrow    ( first )
 import Control.Monad    ( mfilter )
 import Data.Maybe
 import Data.List        ( sortBy )
@@ -216,20 +217,31 @@ procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
 procToFrame initUws blk
  = DwarfFrameProc { dwFdeProc    = dblCLabel blk
                   , dwFdeHasInfo = dblHasInfoTbl blk
-                   , dwFdeBlocks  = map (uncurry blockToFrame) blockUws
+                   , dwFdeBlocks  = map (uncurry blockToFrame)
+                                        (first setHasInfo blockUw0 : blockUws)
                   }
-  where blockUws :: [(DebugBlock, UnwindTable)]
+  where blockUws :: [(DebugBlock, UnwindPoints)]
-        blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk
+        blockUw0:blockUws =
-        flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws,
+          map snd $ sortBy (comparing fst) $ flatten blk
-                                   dblBlocks=blocks }
+        flatten :: DebugBlock
+                -> [(Int, (DebugBlock, UnwindPoints))]
+        flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
          | Just p <- pos  = (p, (b, uws')):nested
          | otherwise      = nested -- block was optimized out
-          where uws'   = uws `Map.union` uws0
+          where uws'   = addDefaultUnwindings initUws uws
-                nested = concatMap (flatten uws') blocks
+                nested = concatMap flatten blocks
-blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock
+        -- | If the current procedure has an info table, then we also say that
+        -- its first block has one to ensure that it gets the necessary -1
+        -- offset applied to its start address.
+        -- See Note [Info Offset] in Dwarf.Types.
+        setHasInfo :: DebugBlock -> DebugBlock
+        setHasInfo child =
+            child { dblHasInfoTbl = dblHasInfoTbl child || dblHasInfoTbl blk }
+blockToFrame :: DebugBlock -> UnwindPoints -> DwarfFrameBlock
 blockToFrame blk uws
-  = DwarfFrameBlock { dwFdeBlock      = mkAsmTempLabel $ dblLabel blk
+  = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
-                    , dwFdeBlkHasInfo = dblHasInfoTbl blk
                    , dwFdeUnwind     = uws
                    }
--- a/compiler/nativeGen/Dwarf/Constants.hs
+++ b/compiler/nativeGen/Dwarf/Constants.hs
@@ -130,9 +130,10 @@ dW_CFA_val_expression     = 0x16
 dW_CFA_offset             = 0x80
 -- * Operations
-dW_OP_deref, dW_OP_consts,
+dW_OP_addr, dW_OP_deref, dW_OP_consts,
  dW_OP_minus, dW_OP_mul, dW_OP_plus,
  dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8
+dW_OP_addr           = 0x03
 dW_OP_deref          = 0x06
 dW_OP_consts         = 0x11
 dW_OP_minus          = 0x1c

--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -35,8 +35,9 @@ import SrcLoc
 import Dwarf.Constants
+import qualified Control.Monad.Trans.State.Strict as S
+import Control.Monad (zipWithM)
 import Data.Bits
-import Data.List ( mapAccumL )
 import qualified Data.Map as Map
 import Data.Word
 import Data.Char
@@ -268,11 +269,13 @@ data DwarfFrameProc
 -- containing FDE.
 data DwarfFrameBlock
  = DwarfFrameBlock
-    { dwFdeBlock      :: CLabel
+    { dwFdeBlkHasInfo :: Bool
-    , dwFdeBlkHasInfo :: Bool
+    , dwFdeUnwind     :: UnwindPoints
-    , dwFdeUnwind     :: UnwindTable
    }
+instance Outputable DwarfFrameBlock where
+  ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds
 -- | Header for the @.debug_frame@ section. Here we emit the "Common
 -- Information Entry" record that etablishes general call frame
 -- parameters and the default stack layout.
@@ -285,6 +288,7 @@ pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
        spReg       = dwarfGlobalRegNo plat Sp
        retReg      = dwarfReturnRegNo plat
        wordSize    = platformWordSize plat
+        pprInit :: (GlobalReg, UnwindExpr) -> SDoc
        pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
        -- Preserve C stack pointer: This necessary to override that default
@@ -337,7 +341,8 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
        procEnd     = mkAsmTempEndLabel procLbl
        ifInfo str  = if hasInfo then text str else empty
                      -- see [Note: Info Offset]
-    in vcat [ pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
+    in pprTrace "FrameProc" (ppr procLbl <+> ppr hasInfo <+> ppr blocks) $
+       vcat [ pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
            , ppr fdeLabel <> colon
            , pprData4' (ppr frameLbl <> char '-' <>
                         ptext dwarfFrameLabel)    -- Reference to CIE
@@ -345,7 +350,7 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
            , pprWord (ppr procEnd <> char '-' <>
                       ppr procLbl <> ifInfo "+1") -- Block byte length
            ] $$
-       vcat (snd $ mapAccumL pprFrameBlock initUw blocks) $$
+       vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
       wordAlign $$
       ppr fdeEndLabel <> colon
@@ -353,22 +358,27 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
 -- instructions where unwind information actually changes. This small
 -- optimisations saves a lot of space, as subsequent blocks often have
 -- the same unwind information.
-pprFrameBlock :: UnwindTable -> DwarfFrameBlock -> (UnwindTable, SDoc)
+pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
-pprFrameBlock oldUws (DwarfFrameBlock blockLbl hasInfo uws)
+pprFrameBlock (DwarfFrameBlock hasInfo (UnwindPoints uws0)) =
-  | uws == oldUws
+    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
-  = (oldUws, empty)
+  where
-  | otherwise
+    pprFrameDecl :: Bool -> (CLabel, UnwindTable) -> S.State UnwindTable SDoc
-  = (,) uws $ sdocWithPlatform $ \plat ->
+    pprFrameDecl firstDecl (lbl, uws) = S.state $ \oldUws ->
-    let lbl = ppr blockLbl <> if hasInfo then text "-1" else empty
+        let isChanged g v | old == Just v  = Nothing
-              -- see [Note: Info Offset]
+                          | otherwise      = Just (old, v)
-        isChanged g v | old == Just v  = Nothing
+                          where old = Map.lookup g oldUws
-                      | otherwise      = Just (old, v)
+            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
-                      where old = Map.lookup g oldUws
+            died    = Map.toList $ Map.difference oldUws uws
-        changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
-        died    = Map.toList $ Map.difference oldUws uws
+        in if oldUws == uws
-    in pprByte dW_CFA_set_loc $$ pprWord lbl $$
+             then (empty, oldUws)
-       vcat (map (uncurry $ pprSetUnwind plat) changed) $$
+             else let needsOffset = firstDecl && hasInfo -- see [Note: Info Offset]
-       vcat (map (pprUndefUnwind plat . fst) died)
+                      lblDoc = ppr lbl <> if needsOffset then text "-1" else empty
+                      doc = sdocWithPlatform $ \plat ->
+                           pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
+                           vcat (map (uncurry $ pprSetUnwind plat) changed) $$
+                           vcat (map (pprUndefUnwind plat . fst) died)
+                  in (doc, uws)
 -- Note [Info Offset]
 --
@@ -446,6 +456,7 @@ pprUnwindExpr spIsCFA expr
        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
                               pprLEBInt i
        pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref
+        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord (ppr l)
        pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
        pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
        pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul

--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -155,9 +155,10 @@ stmtToInstrs stmt = do
  dflags <- getDynFlags
  is32Bit <- is32BitPlatform
  case stmt of
-    CmmComment s   -> return (unitOL (COMMENT s))
+    CmmComment s      -> return (unitOL (COMMENT s))
-    CmmTick {}     -> return nilOL
+    CmmTick {}        -> return nilOL
-    CmmUnwind {}   -> return nilOL
+    CmmUnwind (NewLabel lbl) regs -> return (unitOL (LABEL lbl))
+    CmmUnwind {}      -> return nilOL
    CmmAssign reg src
      | isFloatType ty         -> assignReg_FltCode format reg src

--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -178,6 +178,10 @@ data Instr
        -- invariants for a BasicBlock (see Cmm).
        | NEWBLOCK BlockId
+        -- define a new label within a block. Used to refer to points within a
+        -- block during generation of debugging information.
+        | LABEL BlockId
        -- specify current stack offset for
        -- benefit of subsequent passes
        | DELTA   Int
@@ -783,6 +787,7 @@ x86_isMetaInstr instr
        LOCATION{}      -> True
        LDATA{}         -> True
        NEWBLOCK{}      -> True
+        LABEL{}         -> True
        DELTA{}         -> True
        _               -> False

--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -488,6 +488,9 @@ pprInstr (DELTA d)
 pprInstr (NEWBLOCK _)
   = panic "PprMach.pprInstr: NEWBLOCK"
+pprInstr (LABEL lbl)
+   = pprLabel $ mkAsmTempLabel $ getUnique lbl
 pprInstr (LDATA _ _)
   = panic "PprMach.pprInstr: LDATA"

--- a/rts/StgStartup.cmm
+++ b/rts/StgStartup.cmm
@@ -70,8 +70,8 @@ INFO_TABLE_RET(stg_stop_thread, STOP_FRAME,
       for us by StgRun.
     */
 #ifdef x86_64_HOST_ARCH
-    unwind MachSp = MachSp + RESERVED_C_STACK_BYTES + 0x38 + 8
+    unwind MachSp = MachSp + RESERVED_C_STACK_BYTES + 0x38 + 8,
-    unwind UnwindReturnReg = W_[MachSp + RESERVED_C_STACK_BYTES + 0x38]
+           UnwindReturnReg = W_[MachSp + RESERVED_C_STACK_BYTES + 0x38];
 #endif
    Sp = Sp + SIZEOF_StgStopFrame - WDS(2);
No results found