Generalize CmmUnwind and pass unwind information through NCG

As discussed in D1532, Trac Trac #11337, and Trac Trac #11338, the stack
unwinding information produced by GHC is currently quite approximate.
Essentially we assume that register values do not change at all within a
basic block. While this is somewhat true in normal Haskell code, blocks
containing foreign calls often break this assumption. This results in
unreliable call stacks, especially in the code containing foreign calls.
This is worse than it sounds as unreliable unwinding information can at
times result in segmentation faults.

This patch set attempts to improve this situation by tracking unwinding
information with finer granularity. By dispensing with the assumption of
one unwinding table per block, we allow the compiler to accurately
represent the areas surrounding foreign calls.

Towards this end we generalize the representation of unwind information
in the backend in three ways,

 * Multiple CmmUnwind nodes can occur per block

 * CmmUnwind nodes can now carry unwind information for multiple
   registers (while not strictly necessary; this makes emitting
   unwinding information a bit more convenient in the compiler)

 * The NCG backend is given an opportunity to modify the unwinding
   records since it may need to make adjustments due to, for instance,
   native calling convention requirements for foreign calls (see
   #11353).

This sets the stage for resolving #11337 and #11338.

Test Plan: Validate

Reviewers: scpmw, simonmar, austin, erikd

Subscribers: qnikst, thomie

Differential Revision: https://phabricator.haskell.org/D2741

18 files changed, 450 insertions, 131 deletions

diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 0f8495f3e6..60f89704f0 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -275,10 +275,11 @@ 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
-                              middle_pre sp_off last1 fixup_blocks
+       let 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
+       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.
@@ -793,19 +794,20 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
     adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
     adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
 
-    -- Add unwind pseudo-instructions to document Sp level for debugging
+    -- Add unwind pseudo-instructions at the beginning of each block to
+    -- document Sp level for debugging
     add_unwind_info block
-      | debugLevel dflags > 0 = CmmUnwind Sp sp_unwind : 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 $
-                   blockFromList $
-                   add_unwind_info $
-                   map adj_pre_sp $
-                   elimStackStores stack0 stackmaps area_off $
-                   middle_pre
-
+    final_middle = maybeAddSpAdj dflags sp_off
+                 . blockFromList
+                 . add_unwind_info
+                 . map adj_pre_sp
+                 . elimStackStores stack0 stackmaps area_off
+                 $ middle_pre
     final_last    = optStackCheck (adj_post_sp last)
 
     final_block   = blockJoin first final_middle final_last
@@ -823,9 +825,9 @@ getAreaOff stackmaps (Young l) =
 
 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)
-
+maybeAddSpAdj dflags sp_off block = block `blockSnoc` adj
+  where
+    adj = CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
 
 {-
 Sp(L) is the Sp offset on entry to block L relative to the base of the
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 1103fdb6ec..7acf4c6d8b 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -61,7 +61,9 @@ data CmmNode e x where
     -- 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.
-  CmmUnwind :: !GlobalReg -> !CmmExpr -> CmmNode O O
+    --
+    -- See Note [What is this unwinding business?] in Debug
+  CmmUnwind :: [(GlobalReg, CmmExpr)] -> CmmNode O O
 
   CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
     -- Assign to register
@@ -459,7 +461,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 regs)                      = CmmUnwind (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)
@@ -490,7 +492,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 regs)          = CmmUnwind `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
@@ -543,7 +545,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 xs) z                        = foldr f z (map snd xs)
 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
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index e7425930a6..cfadc61e84 100644
--- 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
-                { $4 >>= code . emitUnwind $2 }
+        | 'unwind' unwind_regs ';'
+                { $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))) }
diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs
index 7b9383569b..02daa3686c 100644
--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -12,15 +12,17 @@
 module Debug (
 
   DebugBlock(..), dblIsEntry,
-  UnwindTable, UnwindExpr(..),
   cmmDebugGen,
   cmmDebugLabels,
   cmmDebugLink,
-  debugToMap
+  debugToMap,
 
+  -- * Unwinding information
+  UnwindTable, UnwindPoint(..),
+  UnwindExpr(..), toUnwindExpr
   ) where
 
-import BlockId         ( blockLbl )
+import BlockId
 import CLabel
 import Cmm
 import CmmUtils
@@ -56,7 +58,7 @@ data DebugBlock =
   , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to
                                    -- other blocks. @Nothing@ means
                                    -- the block was optimized out
-  , dblUnwind     :: !UnwindTable  -- ^ Unwind information
+  , dblUnwind     :: [UnwindPoint]
   , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks
   }
 
@@ -74,14 +76,12 @@ instance Outputable DebugBlock where
             (maybe empty ppr (dblSourceTick blk)) <+>
             (maybe (text "removed") ((text "pos " <>) . ppr)
                    (dblPosition blk)) <+>
-            pprUwMap (dblUnwind blk) $$
+            (ppr (dblUnwind blk)) <+>
             (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
-    where pprUw (g, expr) = ppr g <> char '=' <> ppr expr
-          pprUwMap = braces . hsep . punctuate comma . map pprUw . Map.toList
 
 -- | Intermediate data structure holding debug-relevant context information
 -- about a block.
-type BlockContext = (CmmBlock, RawCmmDecl, UnwindTable)
+type BlockContext = (CmmBlock, RawCmmDecl)
 
 -- | Extract debug data from a group of procedures. We will prefer
 -- source notes that come from the given module (presumably the module
@@ -127,7 +127,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
                    | otherwise                = panic "ticksToCopy impossible"
                 where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
       ticksToCopy _ = []
-      bCtxsTicks = concatMap (blockTicks . fstOf3)
+      bCtxsTicks = concatMap (blockTicks . fst)
 
       -- Finding the "best" source tick is somewhat arbitrary -- we
       -- select the first source span, while preferring source ticks
@@ -151,7 +151,9 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
               nested = fromMaybe [] $ Map.lookup scope scopeMap
               childs = map (mkBlock False) (tail bctxs) ++
                        map (blocksForScope stick) nested
-              mkBlock top (block, prc, unwind)
+
+              mkBlock :: Bool -> BlockContext -> DebugBlock
+              mkBlock top (block, prc)
                 = DebugBlock { dblProcedure    = g_entry graph
                              , dblLabel        = label
                              , dblCLabel       = case info of
@@ -163,9 +165,9 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
                              , dblParent       = Nothing
                              , dblTicks        = ticks
                              , dblPosition     = Nothing -- see cmmDebugLink
-                             , dblUnwind       = unwind
                              , dblSourceTick   = stick
                              , dblBlocks       = blocks
+                             , dblUnwind       = []
                              }
                 where (CmmProc infos entryLbl _ graph) = prc
                       label = entryLabel block
@@ -189,29 +191,33 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
 --
 -- This involves a pre-order traversal, as we want blocks in rough
 -- control flow order (so ticks have a chance to be sorted in the
--- right order). We also use this opportunity to have blocks inherit
--- unwind information from their predecessor blocks where it is
--- lacking.
+-- right order).
 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)
+          | otherwise      = snd $ walkBlock prc entry (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]
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+        walkBlock _   []             c            = c
+        walkBlock prc (block:blocks) (visited, m)
           | lbl `setMember` visited
-          = walkBlock prc blocks unwind (visited, m)
+          = walkBlock prc blocks (visited, m)
           | otherwise
-          = walkBlock prc blocks unwind $
-            walkBlock prc succs unwind'
+          = walkBlock prc blocks $
+            walkBlock prc succs
               (lbl `setInsert` visited,
-               insertMulti scope (block, prc, unwind') m)
+               insertMulti scope (block, prc) m)
           where CmmEntry lbl scope = firstNode block
-                unwind' = extractUnwind block `Map.union` unwind
                 (CmmProc _ _ _ graph) = prc
                 succs = map (flip mapFind (toBlockMap graph))
                             (successors (lastNode block))
@@ -234,14 +240,17 @@ cmmDebugLabels isMeta nats = seqList lbls lbls
         getBlocks _other                         = []
         allMeta (BasicBlock _ instrs) = all isMeta instrs
 
--- | Sets position fields in the debug block tree according to native
--- generated code.
-cmmDebugLink :: [Label] -> [DebugBlock] -> [DebugBlock]
-cmmDebugLink labels blocks = map link blocks
+-- | Sets position and unwind table fields in the debug block tree according to
+-- native generated code.
+cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
+             -> [DebugBlock] -> [DebugBlock]
+cmmDebugLink labels unwindPts blocks = map link blocks
   where blockPos :: LabelMap Int
         blockPos = mapFromList $ flip zip [0..] labels
         link block = block { dblPosition = mapLookup (dblLabel block) blockPos
                            , dblBlocks   = map link (dblBlocks block)
+                           , dblUnwind   = fromMaybe mempty
+                                         $ mapLookup (dblLabel block) unwindPts
                            }
 
 -- | Converts debug blocks into a label map for easier lookups
@@ -249,14 +258,158 @@ debugToMap :: [DebugBlock] -> LabelMap DebugBlock
 debugToMap = mapUnions . map go
    where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
 
+{-
+Note [What is this unwinding business?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwinding tables are a variety of debugging information used by debugging tools
+to reconstruct the execution history of a program at runtime. These tables
+consist of sets of "instructions", one set for every instruction in the program,
+which describe how to reconstruct the state of the machine at the point where
+the current procedure was called. For instance, consider the following annotated
+pseudo-code,
+
+  a_fun:
+    add rsp, 8            -- unwind: rsp = rsp - 8
+    mov rax, 1            -- unwind: rax = unknown
+    call another_block
+    sub rsp, 8            -- unwind: rsp = rsp
+
+We see that attached to each instruction there is an "unwind" annotation, which
+provides a relationship between each updated register and its value at the
+time of entry to a_fun. This is the sort of information that allows gdb to give
+you a stack backtrace given the execution state of your program. This
+unwinding information is captured in various ways by various debug information
+formats; in the case of DWARF (the only format supported by GHC) it is known as
+Call Frame Information (CFI) and can be found in the .debug.frames section of
+your object files.
+
+Currently we only bother to produce unwinding information for registers which
+are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp
+(which is the STG stack pointer) and $rsp (the C stack pointer).
+
+Let's consider how GHC would annotate a C-- program with unwinding information
+with a typical C-- procedure as would come from the STG-to-Cmm code generator,
+
+  entry()
+     { c2fe:
+           v :: P64 = R2;
+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+       c2ff:
+           R2 = v :: P64;
+           R1 = test_closure;
+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+       c2fg:
+           I64[Sp - 8] = c2dD;
+           R1 = v :: P64;
+           Sp = Sp - 8;          // Sp updated here
+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+       c2dE:
+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+       c2dD:
+           w :: P64 = R1;
+           Hp = Hp + 48;
+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+       ...
+  },
+
+Let's consider how this procedure will be decorated with unwind information
+(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the
+value of Sp is no different from what it was at its call site. Therefore we will
+add an `unwind` statement saying this at the beginning of its unwind-annotated
+code,
+
+  entry()
+     { c2fe:
+           unwind Sp = Just Sp + 0;
+           v :: P64 = R2;
+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+
+After c2fe we we may pass to either c2ff or c2fg; let's first consider the
+former. In this case there is nothing in particular that we need to do other
+than reiterate what we already know about Sp,
+
+       c2ff:
+           unwind Sp = Just Sp + 0;
+           R2 = v :: P64;
+           R1 = test_closure;
+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+
+In contrast, c2fg updates Sp midway through its body. To ensure that unwinding
+can happen correctly after this point we must include an unwind statement there,
+in addition to the usual beginning-of-block statement,
+
+       c2fg:
+           unwind Sp = Just Sp + 0;
+           I64[Sp - 8] = c2dD;
+           R1 = v :: P64;
+           unwind Sp = Just Sp + 8;
+           Sp = Sp - 8;
+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+
+The remaining blocks are simple,
+
+       c2dE:
+           unwind Sp = Just Sp + 8;
+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+       c2dD:
+           unwind Sp = Just Sp + 8;
+           w :: P64 = R1;
+           Hp = Hp + 48;
+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+       ...
+  },
+
+
+The flow of unwinding information through the compiler is a bit convoluted:
+
+ * C-- begins life in StgCmm without any unwind information. This is because we
+   haven't actually done any register assignment or stack layout yet, so there
+   is no need for unwind information.
+
+ * CmmLayoutStack figures out how to layout each procedure's stack, and produces
+   appropriate unwinding nodes for each adjustment of the STG Sp register.
+
+ * The unwind nodes are carried through the sinking pass. Currently this is
+   guaranteed not to invalidate unwind information since it won't touch stores
+   to Sp, but this will need revisiting if CmmSink gets smarter in the future.
+
+ * Eventually we make it to the native code generator backend which can then
+   preserve the unwind nodes in its machine-specific instructions. In so doing
+   the backend can also modify or add unwinding information; this is necessary,
+   for instance, in the case of x86-64, where adjustment of $rsp may be
+   necessary during calls to native foreign code due to the native calling
+   convention.
+
+ * The NCG then retrieves the final unwinding table for each block from the
+   backend with extractUnwindPoints.
+
+ * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen
+
+ * These DebugBlcosk are then converted to, e.g., DWARF unwinding tables
+   (by the Dwarf module) and emitted in the final object.
+
+See also: Note [Unwinding information in the NCG] in AsmCodeGen.
+-}
+
+-- | A label associated with an 'UnwindTable'
+data UnwindPoint = UnwindPoint !Label !UnwindTable
+
+instance Outputable UnwindPoint where
+  ppr (UnwindPoint lbl uws) =
+      braces $ ppr lbl<>colon
+      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
+    where
+      pprUw (g, expr) = ppr g <> char '=' <> ppr expr
+
 -- | 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.
 type UnwindTable = Map.Map GlobalReg UnwindExpr
 
 -- | Expressions, used for unwind information
-data UnwindExpr = UwConst Int                   -- ^ literal value
-                | UwReg GlobalReg Int           -- ^ register plus offset
+data UnwindExpr = UwConst !Int                  -- ^ literal value
+                | UwReg !GlobalReg !Int         -- ^ register plus offset
                 | UwDeref UnwindExpr            -- ^ pointer dereferencing
                 | UwLabel CLabel
                 | UwPlus UnwindExpr UnwindExpr
@@ -278,17 +431,6 @@ 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
-  where (_, mid, _) = blockSplit b
-        go :: [CmmNode O O] -> UnwindTable
-        go []       = Map.empty
-        go (x : xs) = case x of
-          CmmUnwind g so -> Map.insert g (toUnwindExpr so) $! go xs
-          CmmTick {}     -> go xs
-          _other         -> Map.empty
-                            -- TODO: Unwind statements after actual instructions
-
 -- | Conversion of Cmm expressions to unwind expressions. We check for
 -- unsupported operator usages and simplify the expression as far as
 -- possible.
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index ae7c5097af..ed795a1d3e 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -14,6 +14,7 @@ module MkGraph
   , mkRawJump
   , mkCbranch, mkSwitch
   , mkReturn, mkComment, mkCallEntry, mkBranch
+  , mkUnwind
   , copyInOflow, copyOutOflow
   , noExtraStack
   , toCall, Transfer(..)
@@ -270,6 +271,8 @@ mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do
 mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
 
+mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
+mkUnwind r e  = mkMiddle $ CmmUnwind [(r, e)]
 
 --------------------------------------------------------------------------
 
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 9517ea3c09..089066a1ab 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -197,7 +197,9 @@ pprNode node = pp_node <+> pp_debug
                    else empty
 
       -- unwind reg = expr;
-      CmmUnwind r e -> text "unwind " <> ppr r <+> char '=' <+> ppr e
+      CmmUnwind regs ->
+          text "unwind "
+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
 
       -- reg = expr;
       CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index a19731295a..d8f268d2bd 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -84,10 +84,10 @@ baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags
 baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags
 baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags
 baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags
-baseRegOffset _      BaseReg             = panic "baseRegOffset:BaseReg"
-baseRegOffset _      PicBaseReg          = panic "baseRegOffset:PicBaseReg"
-baseRegOffset _      MachSp              = panic "baseRegOffset:MachSp"
-baseRegOffset _      UnwindReturnReg     = panic "baseRegOffset:UnwindReturnReg"
+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"
+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"
+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"
+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"
 
 
 -- -----------------------------------------------------------------------------
@@ -137,7 +137,11 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
 
     fixAssign stmt =
       case stmt of
-        CmmAssign (CmmGlobal reg) src ->
+        CmmAssign (CmmGlobal reg) src
+          -- MachSp isn't an STG register; it's merely here for tracking unwind
+          -- information
+          | reg == MachSp -> stmt
+          | otherwise ->
             let baseAddr = get_GlobalReg_addr dflags reg
             in case reg `elem` activeStgRegs (targetPlatform dflags) of
                 True  -> CmmAssign (CmmGlobal reg) src
@@ -145,6 +149,8 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
         other_stmt -> other_stmt
 
     fixExpr expr = case expr of
+        -- MachSp isn't an STG; it's merely here for tracking unwind information
+        CmmReg (CmmGlobal MachSp) -> expr
         CmmReg (CmmGlobal reg) ->
             -- Replace register leaves with appropriate StixTrees for
             -- the given target.  MagicIds which map to a reg on this
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index fadf5ab5a9..c5ad73da4d 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -735,11 +735,11 @@ emitComment _ = return ()
 emitTick :: CmmTickish -> FCode ()
 emitTick = emitCgStmt . CgStmt . CmmTick
 
-emitUnwind :: GlobalReg -> CmmExpr -> FCode ()
-emitUnwind g e = do
+emitUnwind :: [(GlobalReg, CmmExpr)] -> FCode ()
+emitUnwind regs = do
   dflags <- getDynFlags
-  when (debugLevel dflags > 0) $
-     emitCgStmt $ CgStmt $ CmmUnwind g e
+  when (debugLevel dflags > 0) $ do
+     emitCgStmt $ CgStmt $ CmmUnwind regs
 
 emitAssign :: CmmReg  -> CmmExpr -> FCode ()
 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 295ac15a85..2a00379ee5 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -298,7 +298,7 @@ baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
 baseRegOffset dflags HpAlloc        = oFFSET_StgRegTable_rHpAlloc dflags
 baseRegOffset dflags GCEnter1       = oFFSET_stgGCEnter1 dflags
 baseRegOffset dflags GCFun          = oFFSET_stgGCFun dflags
-baseRegOffset _      reg            = pprPanic "baseRegOffset:" (ppr reg)
+baseRegOffset _      reg            = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg)
 
 -------------------------------------------------------------------------
 --
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 7cc7a2804d..b4752cce0c 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -162,7 +162,13 @@ data NcgImpl statics instr jumpDest = NcgImpl {
     ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),
-    ncgMakeFarBranches        :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr]
+    ncgMakeFarBranches        :: LabelMap CmmStatics
+                              -> [NatBasicBlock instr] -> [NatBasicBlock instr],
+    extractUnwindPoints       :: [instr] -> [UnwindPoint]
+    -- ^ given the instruction sequence of a block, produce a list of
+    -- the block's 'UnwindPoint's
+    -- See Note [What is this unwinding business?] in Debug
+    -- and Note [Unwinding information in the NCG] in this module.
     }
 
 --------------------
@@ -209,6 +215,7 @@ x86_64NcgImpl dflags
        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform
        ,ncgExpandTop              = id
        ,ncgMakeFarBranches        = const id
+       ,extractUnwindPoints       = X86.CodeGen.extractUnwindPoints
    }
     where platform = targetPlatform dflags
 
@@ -228,6 +235,7 @@ ppcNcgImpl dflags
        ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform
        ,ncgExpandTop              = id
        ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches
+       ,extractUnwindPoints       = const []
    }
     where platform = targetPlatform dflags
 
@@ -247,6 +255,7 @@ sparcNcgImpl dflags
        ,ncgAllocMoreStack         = noAllocMoreStack
        ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
        ,ncgMakeFarBranches        = const id
+       ,extractUnwindPoints       = const []
    }
 
 --
@@ -279,8 +288,36 @@ data NativeGenAcc statics instr
         , ngs_labels      :: ![Label]
         , ngs_debug       :: ![DebugBlock]
         , ngs_dwarfFiles  :: !DwarfFiles
+        , ngs_unwinds     :: !(LabelMap [UnwindPoint])
+             -- ^ see Note [Unwinding information in the NCG]
+             -- and Note [What is this unwinding business?] in Debug.
         }
 
+{-
+Note [Unwinding information in the NCG]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwind information is a type of metadata which allows a debugging tool
+to reconstruct the values of machine registers at the time a procedure was
+entered. For the most part, the production of unwind information is handled by
+the Cmm stage, where it is represented by CmmUnwind nodes.
+
+Unfortunately, the Cmm stage doesn't know everything necessary to produce
+accurate unwinding information. For instance, the x86-64 calling convention
+requires that the stack pointer be aligned to 16 bytes, which in turn means that
+GHC must sometimes add padding to $sp prior to performing a foreign call. When
+this happens unwind information must be updated accordingly.
+For this reason, we make the NCG backends responsible for producing
+unwinding tables (with the extractUnwindPoints function in NcgImpl).
+
+We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds
+field of NativeGenAcc. This is a label map which contains an entry for each
+procedure, containing a list of unwinding points (e.g. a label and an associated
+unwinding table).
+
+See also Note [What is this unwinding business?] in Debug.
+-}
+
 nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                => DynFlags
                -> Module -> ModLocation
@@ -295,7 +332,7 @@ nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
         -- Pretty if it weren't for the fact that we do lots of little
         -- printDocs here (in order to do codegen in constant space).
         bufh <- newBufHandle h
-        let ngs0 = NGS [] [] [] [] [] [] emptyUFM
+        let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
         (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
                                          cmms ngs0
         finishNativeGen dflags modLoc bufh us' ngs
@@ -386,11 +423,12 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
                              ofBlockList (panic "split_marker_entry") []
               cmms' | splitObjs  = split_marker : cmms
                     | otherwise  = cmms
-          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
-                                      cmms' ngs 0
+          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+                                             dbgMap us cmms' ngs 0
 
           -- Link native code information into debug blocks
-          let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs
+          -- See Note [What is this unwinding business?] in Debug.
+          let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
           dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
             (vcat $ map ppr ldbgs)
 
@@ -430,7 +468,8 @@ cmmNativeGens :: forall statics instr jumpDest.
 
 cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
   where
-    go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int
+    go :: UniqSupply -> [RawCmmDecl]
+       -> NativeGenAcc statics instr -> Int
        -> IO (NativeGenAcc statics instr, UniqSupply)
 
     go us [] ngs !_ =
@@ -438,7 +477,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
 
     go us (cmm : cmms) ngs count = do
         let fileIds = ngs_dwarfFiles ngs
-        (us', fileIds', native, imports, colorStats, linearStats)
+        (us', fileIds', native, imports, colorStats, linearStats, unwinds)
           <- {-# SCC "cmmNativeGen" #-}
              cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
                           cmm count
@@ -463,6 +502,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
                        then cmmDebugLabels isMetaInstr native else []
             !natives' = if dopt Opt_D_dump_asm_stats dflags
                         then native : ngs_natives ngs else []
+
             mCon = maybe id (:)
             ngs' = ngs{ ngs_imports     = imports : ngs_imports ngs
                       , ngs_natives     = natives'
@@ -470,6 +510,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
                       , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
                       , ngs_labels      = ngs_labels ngs ++ labels'
                       , ngs_dwarfFiles  = fileIds'
+                      , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds
                       }
         go us' cmms ngs' (count + 1)
 
@@ -506,7 +547,9 @@ cmmNativeGen
                 , [NatCmmDecl statics instr]                -- native code
                 , [CLabel]                                  -- things imported by this cmm
                 , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
-                , Maybe [Linear.RegAllocStats])             -- stats for the linear register allocators
+                , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators
+                , LabelMap [UnwindPoint]                    -- unwinding information for blocks
+                )
 
 cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
  = do
@@ -659,12 +702,22 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
                 (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
 
+        -- generate unwinding information from cmm
+        let unwinds :: BlockMap [UnwindPoint]
+            unwinds =
+                {-# SCC "unwindingInfo" #-}
+                foldl' addUnwind mapEmpty expanded
+              where
+                addUnwind acc proc =
+                    acc `mapUnion` computeUnwinding dflags ncgImpl proc
+
         return  ( usAlloc
                 , fileIds'
                 , expanded
                 , lastMinuteImports ++ imports
                 , ppr_raStatsColor
-                , ppr_raStatsLinear)
+                , ppr_raStatsLinear
+                , unwinds )
 
 
 x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
@@ -672,6 +725,28 @@ x86fp_kludge top@(CmmData _ _) = top
 x86fp_kludge (CmmProc info lbl live (ListGraph code)) =
         CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)
 
+-- | Compute unwinding tables for the blocks of a procedure
+computeUnwinding :: Instruction instr
+                 => DynFlags -> NcgImpl statics instr jumpDest
+                 -> NatCmmDecl statics instr
+                    -- ^ the native code generated for the procedure
+                 -> LabelMap [UnwindPoint]
+                    -- ^ unwinding tables for all points of all blocks of the
+                    -- procedure
+computeUnwinding dflags _ _
+  | debugLevel dflags == 0         = mapEmpty
+computeUnwinding _ _ (CmmData _ _) = mapEmpty
+computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
+    -- In general we would need to push unwinding information down the
+    -- block-level call-graph to ensure that we fully account for all
+    -- relevant register writes within a procedure.
+    --
+    -- However, the only unwinding information that we care about in GHC is for
+    -- Sp. The fact that CmmLayoutStack already ensures that we have unwind
+    -- information at the beginning of every block means that there is no need
+    -- to perform this sort of push-down.
+    mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
+                | BasicBlock blk_lbl instrs <- blks ]
 
 -- | Build a doc for all the imports.
 --
@@ -928,6 +1003,9 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
 -- the beginning of the block.  For stacks which grow down, this value
 -- should be either zero or negative.
 
+-- Along with the stack pointer offset, we also carry along a LabelMap of
+-- DebugBlocks, which we read to generate .location directives.
+--
 -- Switching between the two monads whilst carrying along the same
 -- Unique supply breaks abstraction.  Is that bad?
 
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index 3b299746a9..1aabd72164 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -17,6 +17,7 @@ import UniqSupply
 import Dwarf.Constants
 import Dwarf.Types
 
+import Control.Arrow    ( first )
 import Control.Monad    ( mfilter )
 import Data.Maybe
 import Data.List        ( sortBy )
@@ -215,20 +216,42 @@ procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
 procToFrame initUws blk
   = DwarfFrameProc { dwFdeProc    = dblCLabel blk
                    , dwFdeHasInfo = dblHasInfoTbl blk
-                   , dwFdeBlocks  = map (uncurry blockToFrame) blockUws
+                   , dwFdeBlocks  = map (uncurry blockToFrame)
+                                        (setHasInfo blockUws)
                    }
-  where blockUws :: [(DebugBlock, UnwindTable)]
-        blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk
-        flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws,
-                                   dblBlocks=blocks }
+  where blockUws :: [(DebugBlock, [UnwindPoint])]
+        blockUws = map snd $ sortBy (comparing fst) $ flatten blk
+
+        flatten :: DebugBlock
+                -> [(Int, (DebugBlock, [UnwindPoint]))]
+        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
-                nested = concatMap (flatten uws') blocks
+          where uws'   = addDefaultUnwindings initUws uws
+                nested = concatMap flatten blocks
+
+        -- | 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, [UnwindPoint])]
+                   -> [(DebugBlock, [UnwindPoint])]
+        setHasInfo [] = []
+        setHasInfo (c0:cs) = first setIt c0 : cs
+          where
+            setIt child =
+              child { dblHasInfoTbl = dblHasInfoTbl child
+                                      || dblHasInfoTbl blk }
 
-blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock
+blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
 blockToFrame blk uws
-  = DwarfFrameBlock { dwFdeBlock      = mkAsmTempLabel $ dblLabel blk
-                    , dwFdeBlkHasInfo = dblHasInfoTbl blk
+  = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
                     , dwFdeUnwind     = uws
                     }
+
+addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
+addDefaultUnwindings tbl pts =
+    [ UnwindPoint lbl (tbl' `mappend` tbl)
+      -- mappend is left-biased
+    | UnwindPoint lbl tbl' <- pts
+    ]
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
index 0fcd926c53..c1a866fe19 100644
--- 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,15 @@ data DwarfFrameProc
 -- containing FDE.
 data DwarfFrameBlock
   = DwarfFrameBlock
-    { dwFdeBlock      :: CLabel
-    , dwFdeBlkHasInfo :: Bool
-    , dwFdeUnwind     :: UnwindTable
+    { dwFdeBlkHasInfo :: Bool
+    , dwFdeUnwind     :: [UnwindPoint]
+      -- ^ these unwind points must occur in the same order as they occur
+      -- in the block
     }
 
+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 +290,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 +343,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 vcat [ ifPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
+            , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
             , ppr fdeLabel <> colon
             , pprData4' (ppr frameLbl <> char '-' <>
                          ptext dwarfFrameLabel)    -- Reference to CIE
@@ -345,7 +352,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 +360,29 @@ 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 oldUws (DwarfFrameBlock blockLbl hasInfo uws)
-  | uws == oldUws
-  = (oldUws, empty)
-  | otherwise
-  = (,) uws $ sdocWithPlatform $ \plat ->
-    let lbl = ppr blockLbl <> if hasInfo then text "-1" else empty
-              -- see [Note: Info Offset]
-        isChanged g v | old == Just v  = Nothing
-                      | otherwise      = Just (old, v)
-                      where old = Map.lookup g oldUws
-        changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
-        died    = Map.toList $ Map.difference oldUws uws
-    in pprByte dW_CFA_set_loc $$ pprWord lbl $$
-       vcat (map (uncurry $ pprSetUnwind plat) changed) $$
-       vcat (map (pprUndefUnwind plat . fst) died)
+pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
+pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
+    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
+  where
+    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
+    pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
+        let isChanged g v | old == Just v  = Nothing
+                          | otherwise      = Just (old, v)
+                          where old = Map.lookup g oldUws
+            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
+            died    = Map.toList $ Map.difference oldUws uws
+
+        in if oldUws == uws
+             then (empty, oldUws)
+             else let -- see [Note: Info Offset]
+                      needsOffset = firstDecl && hasInfo
+                      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]
 --
@@ -442,7 +456,7 @@ pprUnwindExpr spIsCFA expr
         pprE (UwReg Sp i) | spIsCFA
                              = if i == 0
                                then pprByte dW_OP_call_frame_cfa
-                               else ppr (UwPlus (UwReg Sp 0) (UwConst i))
+                               else pprE (UwPlus (UwReg Sp 0) (UwConst i))
         pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
                                pprLEBInt i
         pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index ca5bafe63a..34aaa17701 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -85,7 +85,6 @@ initNat :: NatM_State -> NatM a -> (a, NatM_State)
 initNat init_st m
         = case unNat m init_st of { (r,st) -> (r,st) }
 
-
 instance Functor NatM where
       fmap = liftM
 
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index b60d61047f..b1f11e4bf9 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -21,6 +21,7 @@
 module X86.CodeGen (
         cmmTopCodeGen,
         generateJumpTableForInstr,
+        extractUnwindPoints,
         InstrBlock
 )
 
@@ -37,7 +38,8 @@ import X86.Regs
 import X86.RegInfo
 import CodeGen.Platform
 import CPrim
-import Debug            ( DebugBlock(..) )
+import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable
+                        , UnwindExpr(UwReg), toUnwindExpr )
 import Instruction
 import PIC
 import NCGMonad
@@ -69,10 +71,13 @@ import Util
 
 import Control.Monad
 import Data.Bits
+import Data.Foldable (fold)
 import Data.Int
 import Data.Maybe
 import Data.Word
 
+import qualified Data.Map as M
+
 is32BitPlatform :: NatM Bool
 is32BitPlatform = do
     dflags <- getDynFlags
@@ -134,12 +139,13 @@ basicBlockCodeGen block = do
   mid_instrs <- stmtsToInstrs stmts
   tail_instrs <- stmtToInstrs tail
   let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
+  instrs' <- fold <$> traverse addSpUnwindings instrs
   -- code generation may introduce new basic block boundaries, which
   -- are indicated by the NEWBLOCK instruction.  We must split up the
   -- instruction stream into basic blocks again.  Also, we extract
   -- LDATAs here too.
   let
-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'
 
         mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
           = ([], BasicBlock id instrs : blocks, statics)
@@ -149,6 +155,18 @@ basicBlockCodeGen block = do
           = (instr:instrs, blocks, statics)
   return (BasicBlock id top : other_blocks, statics)
 
+-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes
+-- in the @sp@ register. See Note [What is this unwinding business?] in Debug
+-- for details.
+addSpUnwindings :: Instr -> NatM (OrdList Instr)
+addSpUnwindings instr@(DELTA d) = do
+    dflags <- getDynFlags
+    if debugLevel dflags >= 1
+        then do lbl <- newBlockId
+                let unwind = M.singleton MachSp (UwReg MachSp $ negate d)
+                return $ toOL [ instr, UNWIND lbl unwind ]
+        else return (unitOL instr)
+addSpUnwindings instr = return $ unitOL instr
 
 stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
 stmtsToInstrs stmts
@@ -163,7 +181,15 @@ stmtToInstrs stmt = do
   case stmt of
     CmmComment s   -> return (unitOL (COMMENT s))
     CmmTick {}     -> return nilOL
-    CmmUnwind {}   -> return nilOL
+
+    CmmUnwind regs -> do
+      let to_unwind_entry :: (GlobalReg, CmmExpr) -> UnwindTable
+          to_unwind_entry (reg, expr) = M.singleton reg (toUnwindExpr expr)
+      case foldMap to_unwind_entry regs of
+        tbl | M.null tbl -> return nilOL
+            | otherwise  -> do
+                lbl <- newBlockId
+                return $ unitOL $ UNWIND lbl tbl
 
     CmmAssign reg src
       | isFloatType ty         -> assignReg_FltCode format reg src
@@ -2264,8 +2290,7 @@ genCCall32' dflags target dest_regs args = do
             ChildCode64 code r_lo <- iselExpr64 arg
             delta <- getDeltaNat
             setDeltaNat (delta - 8)
-            let
-                r_hi = getHiVRegFromLo r_lo
+            let r_hi = getHiVRegFromLo r_lo
             return (       code `appOL`
                            toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
                                  PUSH II32 (OpReg r_lo), DELTA (delta - 8),
@@ -2713,6 +2738,10 @@ createJumpTable dflags ids section lbl
             | otherwise = map (jumpTableEntry dflags) ids
       in CmmData section (1, Statics lbl jumpTable)
 
+extractUnwindPoints :: [Instr] -> [UnwindPoint]
+extractUnwindPoints instrs =
+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]
+
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers
 
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 0fabf71cfd..4b43a1cf27 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -39,6 +39,7 @@ import DynFlags
 import UniqSet
 import Unique
 import UniqSupply
+import Debug (UnwindTable)
 
 import Control.Monad
 import Data.Maybe       (fromMaybe)
@@ -179,9 +180,13 @@ data Instr
         -- invariants for a BasicBlock (see Cmm).
         | NEWBLOCK BlockId
 
-        -- specify current stack offset for
-        -- benefit of subsequent passes
-        | DELTA   Int
+        -- unwinding information
+        -- See Note [Unwinding information in the NCG].
+        | UNWIND BlockId UnwindTable
+
+        -- specify current stack offset for benefit of subsequent passes.
+        -- This carries a BlockId so it can be used in unwinding information.
+        | DELTA  Int
 
         -- Moves.
         | MOV         Format Operand Operand
@@ -448,6 +453,7 @@ x86_regUsageOfInstr platform instr
 
     COMMENT _           -> noUsage
     LOCATION{}          -> noUsage
+    UNWIND{}            -> noUsage
     DELTA   _           -> noUsage
 
     POPCNT _ src dst -> mkRU (use_R src []) [dst]
@@ -621,6 +627,7 @@ x86_patchRegsOfInstr instr env
     NOP                 -> instr
     COMMENT _           -> instr
     LOCATION {}         -> instr
+    UNWIND {}           -> instr
     DELTA _             -> instr
 
     JXX _ _             -> instr
@@ -784,6 +791,7 @@ x86_isMetaInstr instr
         LOCATION{}      -> True
         LDATA{}         -> True
         NEWBLOCK{}      -> True
+        UNWIND{}        -> True
         DELTA{}         -> True
         _               -> False
 
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index f4ca20987a..1864fc1ba8 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -514,23 +514,27 @@ pprDataItem' dflags lit
                 = panic "X86.Ppr.ppr_item: no match"
 
 
+asmComment :: SDoc -> SDoc
+asmComment c = ifPprDebug $ text "# " <> c
 
 pprInstr :: Instr -> SDoc
 
-pprInstr (COMMENT _) = empty -- nuke 'em
-{-
-pprInstr (COMMENT s) = text "# " <> ftext s
--}
+pprInstr (COMMENT s)
+   = asmComment (ftext s)
 
 pprInstr (LOCATION file line col _name)
    = text "\t.loc " <> ppr file <+> ppr line <+> ppr col
 
 pprInstr (DELTA d)
-   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+   = asmComment $ text ("\tdelta = " ++ show d)
 
 pprInstr (NEWBLOCK _)
    = panic "PprMach.pprInstr: NEWBLOCK"
 
+pprInstr (UNWIND lbl d)
+   = asmComment (text "\tunwind = " <> ppr d)
+     $$ ppr lbl <> colon
+
 pprInstr (LDATA _ _)
    = panic "PprMach.pprInstr: LDATA"
 
diff --git a/rts/StgStartup.cmm b/rts/StgStartup.cmm
index aad4fab139..a3a75d8211 100644
--- 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 UnwindReturnReg = W_[MachSp + RESERVED_C_STACK_BYTES + 0x38]
+    unwind MachSp = MachSp + RESERVED_C_STACK_BYTES + 0x38 + 8,
+           UnwindReturnReg = W_[MachSp + RESERVED_C_STACK_BYTES + 0x38];
 #endif
 
     Sp = Sp + SIZEOF_StgStopFrame - WDS(2);
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index 5412b62ab1..9a9a640d5d 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -123,7 +123,7 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do
     mapM (\ (count, thisCmm) ->
         cmmNativeGen dflags thisMod thisModLoc ncgImpl
             usb dwarfFileIds dbgMap thisCmm count >>=
-                (\(_, _, _, _, colorStats, linearStats) ->
+                (\(_, _, _, _, colorStats, linearStats, _) ->
                 -- scrub unneeded output from cmmNativeGen
                 return (colorStats, linearStats)))
                 $ zip [0.. (length collectedCmms)] collectedCmms