Cmm: Add support for undefined unwinding statements

And use to mark `stg_stack_underflow_frame`, which we are unable to
determine a caller from.

To simplify parsing at the moment we steal the `return` keyword to
indicate an undefined unwind value. Perhaps this should be revisited.

Reviewers: scpmw, simonmar, austin, erikd

Subscribers: dfeuer, thomie

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

10 files changed, 68 insertions, 36 deletions

diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index fbd1d71cfb..f59daad64d 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -530,7 +530,7 @@ makeFixupBlock dflags sp0 l stack tscope assigs
     let sp_off = sp0 - sm_sp stack
         maybeAddUnwind block
           | debugLevel dflags > 0
-          = block `blockSnoc` CmmUnwind [(Sp, unwind_val)]
+          = block `blockSnoc` CmmUnwind [(Sp, Just unwind_val)]
           | otherwise
           = block
           where unwind_val = cmmOffset dflags (CmmReg spReg) (sm_sp stack)
@@ -805,9 +805,10 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
     -- 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
-      | otherwise             = block
+      | debugLevel dflags > 0
+      = CmmUnwind [(Sp, Just sp_unwind)] : block
+      | otherwise
+      = block
     sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 - wORD_SIZE dflags)
 
     final_middle = maybeAddSpAdj dflags sp_off
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 7acf4c6d8b..a3393903ad 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -63,7 +63,7 @@ data CmmNode e x where
     -- debugger to "walk" the stack.
     --
     -- See Note [What is this unwinding business?] in Debug
-  CmmUnwind :: [(GlobalReg, CmmExpr)] -> CmmNode O O
+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
 
   CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
     -- Assign to register
@@ -461,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 regs)                      = CmmUnwind (map (fmap f) regs)
+mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (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)
@@ -492,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 regs)          = CmmUnwind `fmap` mapM (\(r,e) -> f e >>= \e' -> pure (r,e')) regs
+mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM 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
@@ -545,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 xs) z                        = foldr f z (map snd xs)
+foldExp f (CmmUnwind xs) z                        = foldr (maybe id 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 cfadc61e84..69925811ce 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -639,12 +639,20 @@ stmt    :: { CmmParse () }
                 { $2 >>= code . emitUnwind }
 
 unwind_regs
-        :: { CmmParse [(GlobalReg, CmmExpr)] }
-        : GLOBALREG '=' expr ',' unwind_regs
+        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
+        : GLOBALREG '=' expr_or_unknown ',' unwind_regs
                 { do e <- $3; rest <- $5; return (($1, e) : rest) }
-        | GLOBALREG '=' expr
+        | GLOBALREG '=' expr_or_unknown
                 { do e <- $3; return [($1, e)] }
 
+-- | Used by unwind to indicate unknown unwinding values.
+expr_or_unknown
+        :: { CmmParse (Maybe CmmExpr) }
+        : 'return'
+                { do return Nothing }
+        | expr
+                { do e <- $1; return (Just 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 02daa3686c..79026949f6 100644
--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -403,9 +403,11 @@ instance Outputable UnwindPoint 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
+-- further up the stack. Most interesting for the stack pointer @Sp@,
+-- but might be useful to document saved registers, too. Note that a
+-- register's value will be 'Nothing' when the register's previous
+-- value cannot be reconstructed.
+type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)
 
 -- | Expressions, used for unwind information
 data UnwindExpr = UwConst !Int                  -- ^ literal value
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index ed795a1d3e..f77392fbc2 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -271,8 +271,10 @@ 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
 
+-- | Construct a 'CmmUnwind' node for the given register and unwinding
+-- expression.
 mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
-mkUnwind r e  = mkMiddle $ CmmUnwind [(r, e)]
+mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]
 
 --------------------------------------------------------------------------
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index c5ad73da4d..bb093a5e51 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -735,7 +735,7 @@ emitComment _ = return ()
 emitTick :: CmmTickish -> FCode ()
 emitTick = emitCgStmt . CgStmt . CmmTick
 
-emitUnwind :: [(GlobalReg, CmmExpr)] -> FCode ()
+emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
 emitUnwind regs = do
   dflags <- getDynFlags
   when (debugLevel dflags > 0) $ do
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index 1aabd72164..1066169639 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -209,7 +209,9 @@ debugFrame u procs
                , dwCieInit  = initUws
                , dwCieProcs = map (procToFrame initUws) procs
                }
-  where initUws = Map.fromList [(Sp, UwReg Sp 0)]
+  where
+    initUws :: UnwindTable
+    initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]
 
 -- | Generates unwind information for a procedure debug block
 procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
index c1a866fe19..b5348db843 100644
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -36,7 +36,7 @@ import SrcLoc
 import Dwarf.Constants
 
 import qualified Control.Monad.Trans.State.Strict as S
-import Control.Monad (zipWithM)
+import Control.Monad (zipWithM, join)
 import Data.Bits
 import qualified Data.Map as Map
 import Data.Word
@@ -290,7 +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 :: (GlobalReg, Maybe UnwindExpr) -> SDoc
         pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
 
         -- Preserve C stack pointer: This necessary to override that default
@@ -366,11 +366,21 @@ pprFrameBlock (DwarfFrameBlock hasInfo 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
+        let -- Did a register's unwind expression change?
+            isChanged :: GlobalReg -> Maybe UnwindExpr
+                      -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
+            isChanged g new
+                -- the value didn't change
+              | Just new == old = Nothing
+                -- the value was and still is undefined
+              | Nothing <- old
+              , Nothing <- new  = Nothing
+                -- the value changed
+              | otherwise       = Just (join old, new)
+              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)
@@ -380,8 +390,7 @@ pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
                                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)
+                           vcat (map (uncurry $ pprSetUnwind plat) changed)
                   in (doc, uws)
 
 -- Note [Info Offset]
@@ -412,12 +421,19 @@ dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
 -- | Generate code for setting the unwind information for a register,
 -- optimized using its known old value in the table. Note that "Sp" is
 -- special: We see it as synonym for the CFA.
-pprSetUnwind :: Platform -> GlobalReg -> (Maybe UnwindExpr, UnwindExpr) -> SDoc
-pprSetUnwind _    Sp (Just (UwReg s _), UwReg s' o') | s == s'
+pprSetUnwind :: Platform
+             -> GlobalReg
+                -- ^ the register to produce an unwinding table entry for
+             -> (Maybe UnwindExpr, Maybe UnwindExpr)
+                -- ^ the old and new values of the register
+             -> SDoc
+pprSetUnwind plat g  (_, Nothing)
+  = pprUndefUnwind plat g
+pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
   = if o' >= 0
     then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
     else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
-pprSetUnwind plat Sp (_, UwReg s' o')
+pprSetUnwind plat Sp (_, Just (UwReg s' o'))
   = if o' >= 0
     then pprByte dW_CFA_def_cfa $$
          pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$
@@ -425,9 +441,9 @@ pprSetUnwind plat Sp (_, UwReg s' o')
     else pprByte dW_CFA_def_cfa_sf $$
          pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat s') $$
          pprLEBInt o'
-pprSetUnwind _    Sp (_, uw)
+pprSetUnwind _    Sp (_, Just uw)
   = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
-pprSetUnwind plat g  (_, UwDeref (UwReg Sp o))
+pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))
   | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case
   = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
     pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))
@@ -435,11 +451,11 @@ pprSetUnwind plat g  (_, UwDeref (UwReg Sp o))
   = pprByte dW_CFA_offset_extended_sf $$
     pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
     pprLEBInt o
-pprSetUnwind plat g  (_, UwDeref uw)
+pprSetUnwind plat g  (_, Just (UwDeref uw))
   = pprByte dW_CFA_expression $$
     pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
     pprUnwindExpr True uw
-pprSetUnwind plat g  (_, uw)
+pprSetUnwind plat g  (_, Just uw)
   = pprByte dW_CFA_val_expression $$
     pprLEBWord (fromIntegral (dwarfGlobalRegNo plat g)) $$
     pprUnwindExpr True uw
@@ -471,7 +487,6 @@ pprUnwindExpr spIsCFA expr
 -- | Generate code for re-setting the unwind information for a
 -- register to @undefined@
 pprUndefUnwind :: Platform -> GlobalReg -> SDoc
-pprUndefUnwind _    Sp = panic "pprUndefUnwind Sp" -- should never happen
 pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$
                          pprLEBWord (fromIntegral $ dwarfGlobalRegNo plat g)
 
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index b1f11e4bf9..a0a8f9d0be 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -163,7 +163,7 @@ addSpUnwindings instr@(DELTA d) = do
     dflags <- getDynFlags
     if debugLevel dflags >= 1
         then do lbl <- newBlockId
-                let unwind = M.singleton MachSp (UwReg MachSp $ negate d)
+                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)
                 return $ toOL [ instr, UNWIND lbl unwind ]
         else return (unitOL instr)
 addSpUnwindings instr = return $ unitOL instr
@@ -183,8 +183,8 @@ stmtToInstrs stmt = do
     CmmTick {}     -> return nilOL
 
     CmmUnwind regs -> do
-      let to_unwind_entry :: (GlobalReg, CmmExpr) -> UnwindTable
-          to_unwind_entry (reg, expr) = M.singleton reg (toUnwindExpr expr)
+      let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
+          to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)
       case foldMap to_unwind_entry regs of
         tbl | M.null tbl -> return nilOL
             | otherwise  -> do
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index e8a5b8fed5..88371f2109 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -26,6 +26,8 @@ INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME,
                 W_ info_ptr, P_ unused)
     /* no args => explicit stack */
 {
+    unwind UnwindReturnReg = return;
+
     W_ new_tso;
     W_ ret_off;