summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CmmCommonBlockElim.hs1
-rw-r--r--compiler/cmm/CmmLayoutStack.hs7
-rw-r--r--compiler/cmm/CmmLex.x2
-rw-r--r--compiler/cmm/CmmLint.hs1
-rw-r--r--compiler/cmm/CmmNode.hs10
-rw-r--r--compiler/cmm/CmmParse.y3
-rw-r--r--compiler/cmm/PprCmm.hs4
-rw-r--r--compiler/codeGen/StgCmmMonad.hs8
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs1
-rw-r--r--compiler/nativeGen/PPC/CodeGen.hs1
-rw-r--r--compiler/nativeGen/SPARC/CodeGen.hs1
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs1
-rw-r--r--rts/Exception.cmm1
-rw-r--r--rts/StgMiscClosures.cmm1
-rw-r--r--utils/genapply/GenApply.hs1
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[] ="
View Lorry Controller Status