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

5 files changed, 28 insertions, 15 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)]
 
 --------------------------------------------------------------------------