Add unwind information to Cmm

Unwind information allows the debugger to discover more information
about a program state, by allowing it to "reconstruct" other states of
the program. In practice, this means that we explain to the debugger
how to unravel stack frames, which comes down mostly to explaining how
to find their Sp and Ip register values.

* We declare yet another new constructor for CmmNode - and this time
  there's actually little choice, as unwind information can and will
  change mid-block. We don't actually make use of these capabilities,
  and back-end support would be tricky (generate new labels?), but it
  feels like the right way to do it.

* Even though we only use it for Sp so far, we allow CmmUnwind to specify
  unwind information for any register. This is pretty cheap and could
  come in useful in future.

* We allow full CmmExpr expressions for specifying unwind values. The
  advantage here is that we don't have to make up new syntax, and can e.g.
  use the WDS macro directly. On the other hand, the back-end will now
  have to simplify the expression until it can sensibly be converted
  into DWARF byte code - a process which might fail, yielding NCG panics.
  On the other hand, when you're writing Cmm by hand you really ought to
  know what you're doing.

(From Phabricator D169)

15 files changed, 42 insertions, 1 deletions

diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index e009ce5171..95910d16d5 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -92,6 +92,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 (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
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 7df0af6c68..8439240b7e 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -794,8 +794,15 @@ 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_info block
+      | gopt Opt_Debug dflags = 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
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
index f56db7bd4c..d5a8067486 100644
--- a/compiler/cmm/CmmLex.x
+++ b/compiler/cmm/CmmLex.x
@@ -160,6 +160,7 @@ data CmmToken
   | CmmT_case
   | CmmT_default
   | CmmT_push
+  | CmmT_unwind
   | CmmT_bits8
   | CmmT_bits16
   | CmmT_bits32
@@ -243,6 +244,7 @@ reservedWordsFM = listToUFM $
         ( "case",               CmmT_case ),
         ( "default",            CmmT_default ),
         ( "push",               CmmT_push ),
+        ( "unwind",             CmmT_unwind ),
         ( "bits8",              CmmT_bits8 ),
         ( "bits16",             CmmT_bits16 ),
         ( "bits32",             CmmT_bits32 ),
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 4ab726ea87..e5938150e7 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -141,6 +141,7 @@ lintCmmMiddle :: CmmNode O O -> CmmLint ()
 lintCmmMiddle node = case node of
   CmmComment _ -> return ()
   CmmTick _    -> return ()
+  CmmUnwind{}  -> return ()
 
   CmmAssign reg expr -> do
             dflags <- getDynFlags
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 2376b422a6..b405360e87 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -52,6 +52,13 @@ data CmmNode e x where
     -- See Note [CmmTick scoping details]
   CmmTick :: !CmmTickish -> CmmNode O O
 
+    -- Unwind pseudo-instruction, encoding stack unwinding
+    -- 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.
+  CmmUnwind :: !GlobalReg -> !CmmExpr -> CmmNode O O
+
   CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
     -- Assign to register
 
@@ -449,6 +456,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   (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)
@@ -479,6 +487,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 (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
@@ -531,6 +540,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 (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 c911606825..6b51e51367 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -325,6 +325,7 @@ import Data.Maybe
         'case'          { L _ (CmmT_case) }
         'default'       { L _ (CmmT_default) }
         'push'          { L _ (CmmT_push) }
+        'unwind'        { L _ (CmmT_unwind) }
         'bits8'         { L _ (CmmT_bits8) }
         'bits16'        { L _ (CmmT_bits16) }
         'bits32'        { L _ (CmmT_bits32) }
@@ -634,6 +635,8 @@ stmt    :: { CmmParse () }
                 { pushStackFrame $3 $5 }
         | 'reserve' expr '=' lreg maybe_body
                 { reserveStackFrame $2 $4 $5 }
+        | 'unwind' GLOBALREG '=' expr
+                { $4 >>= code . emitUnwind $2 }
 
 foreignLabel     :: { CmmParse CmmExpr }
         : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 23982127a0..9d9f3081dc 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -195,6 +195,9 @@ pprNode node = pp_node <+> pp_debug
                    then ptext (sLit "//tick") <+> ppr t
                    else empty
 
+      -- unwind reg = expr;
+      CmmUnwind r e -> ptext (sLit "unwind ") <> ppr r <+> char '=' <+> ppr e
+
       -- reg = expr;
       CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 
@@ -278,6 +281,7 @@ pprNode node = pp_node <+> pp_debug
              CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
              CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
              CmmTick {}              -> empty
+             CmmUnwind {}            -> text "  // CmmUnwind"
              CmmAssign {}            -> text "  // CmmAssign"
              CmmStore {}             -> text "  // CmmStore"
              CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index cf78d512cc..fff8e28654 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -20,7 +20,7 @@ module StgCmmMonad (
         emit, emitDecl, emitProc,
         emitProcWithConvention, emitProcWithStackFrame,
         emitOutOfLine, emitAssign, emitStore, emitComment,
-        emitTick,
+        emitTick, emitUnwind,
 
         getCmm, aGraphToGraph,
         getCodeR, getCode, getCodeScoped, getHeapUsage,
@@ -726,6 +726,12 @@ emitComment _ = return ()
 emitTick :: CmmTickish -> FCode ()
 emitTick = emitCgStmt . CgStmt . CmmTick
 
+emitUnwind :: GlobalReg -> CmmExpr -> FCode ()
+emitUnwind g e = do
+  dflags <- getDynFlags
+  when (gopt Opt_Debug dflags) $
+     emitCgStmt $ CgStmt $ CmmUnwind g e
+
 emitAssign :: CmmReg  -> CmmExpr -> FCode ()
 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
 
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 5a2f90acaf..c7be2c3194 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -104,6 +104,7 @@ stmtToInstrs stmt = case stmt of
 
     CmmComment _         -> return (nilOL, []) -- nuke comments
     CmmTick    _         -> return (nilOL, [])
+    CmmUnwind  {}        -> return (nilOL, [])
 
     CmmAssign reg src    -> genAssign reg src
     CmmStore addr src    -> genStore addr src
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index c04814d2fe..63a7c18c7d 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -127,6 +127,7 @@ stmtToInstrs stmt = do
   case stmt of
     CmmComment s   -> return (unitOL (COMMENT s))
     CmmTick {}     -> return nilOL
+    CmmUnwind {}   -> return nilOL
 
     CmmAssign reg src
       | isFloatType ty -> assignReg_FltCode size reg src
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 14855ed7fd..bba849da61 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -127,6 +127,7 @@ stmtToInstrs stmt = do
   case stmt of
     CmmComment s   -> return (unitOL (COMMENT s))
     CmmTick {}     -> return nilOL
+    CmmUnwind {}   -> return nilOL
 
     CmmAssign reg src
       | isFloatType ty  -> assignReg_FltCode size reg src
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 7c0ba2d4da..86d4b17abe 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -146,6 +146,7 @@ stmtToInstrs stmt = do
   case stmt of
     CmmComment s   -> return (unitOL (COMMENT s))
     CmmTick {}     -> return nilOL
+    CmmUnwind {}   -> return nilOL
 
     CmmAssign reg src
       | isFloatType ty         -> assignReg_FltCode size reg src
diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index e03d53e1d5..5007ef3c0c 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -58,6 +58,7 @@ import ghczmprim_GHCziTypes_True_closure;
 INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
     /* explicit stack */
 {
+    unwind Sp = Sp + WDS(1);
     CInt r;
 
     P_ ret;
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index f57fc04263..dd2570617d 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -47,6 +47,7 @@ INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME,
 
 INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ info_ptr, W_ cccs)
 {
+    unwind Sp = Sp + WDS(2);
 #if defined(PROFILING)
     CCCS = Sp(1);
 #endif
diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs
index 7b84a27d64..7ff1b877a0 100644
--- a/utils/genapply/GenApply.hs
+++ b/utils/genapply/GenApply.hs
@@ -605,6 +605,7 @@ genApply regstatus args =
       nest 4 (vcat [
        text "W_ info;",
        text "W_ arity;",
+       text "unwind Sp = Sp + WDS(" <> int (1+all_args_size) <> text ");",
 
 --    if fast == 1:
 --        print "static void *lbls[] ="