Commit 3328ddb8 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

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
parent 733e845d
......@@ -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
......
......@@ -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
......
......@@ -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))) }
......
......@@ -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
......
......@@ -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)]
--------------------------------------------------------------------------
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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;
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment