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

3 files changed, 16 insertions, 10 deletions

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)
 
 -------------------------------------------------------------------------
 --