summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CmmLayoutStack.hs32
-rw-r--r--compiler/cmm/CmmNode.hs10
-rw-r--r--compiler/cmm/CmmParse.y11
-rw-r--r--compiler/cmm/Debug.hs222
-rw-r--r--compiler/cmm/MkGraph.hs3
-rw-r--r--compiler/cmm/PprCmm.hs4
-rw-r--r--compiler/codeGen/CgUtils.hs16
-rw-r--r--compiler/codeGen/StgCmmMonad.hs8
-rw-r--r--compiler/codeGen/StgCmmUtils.hs2
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs96
-rw-r--r--compiler/nativeGen/Dwarf.hs43
-rw-r--r--compiler/nativeGen/Dwarf/Types.hs60
-rw-r--r--compiler/nativeGen/NCGMonad.hs1
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs39
-rw-r--r--compiler/nativeGen/X86/Instr.hs14
-rw-r--r--compiler/nativeGen/X86/Ppr.hs14
-rw-r--r--rts/StgStartup.cmm4
-rw-r--r--testsuite/tests/regalloc/regalloc_unit_tests.hs2
18 files changed, 450 insertions, 131 deletions
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 0f8495f3e6..60f89704f0 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -275,10 +275,11 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high
--
let middle_pre = blockToList $ foldl blockSnoc middle1 middle2
- final_blocks = manifestSp dflags final_stackmaps stack0 sp0 final_sp_high entry0
- middle_pre sp_off last1 fixup_blocks
+ let final_blocks =
+ manifestSp dflags final_stackmaps stack0 sp0 final_sp_high
+ entry0 middle_pre sp_off last1 fixup_blocks
- acc_stackmaps' = mapUnion acc_stackmaps out
+ let acc_stackmaps' = mapUnion acc_stackmaps out
-- If this block jumps to the GC, then we do not take its
-- stack usage into account for the high-water mark.
@@ -793,19 +794,20 @@ 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 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
+ | debugLevel dflags > 0 =
+ 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
-
+ final_middle = maybeAddSpAdj dflags sp_off
+ . blockFromList
+ . add_unwind_info
+ . map adj_pre_sp
+ . elimStackStores stack0 stackmaps area_off
+ $ middle_pre
final_last = optStackCheck (adj_post_sp last)
final_block = blockJoin first final_middle final_last
@@ -823,9 +825,9 @@ getAreaOff stackmaps (Young l) =
maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj _ 0 block = block
-maybeAddSpAdj dflags sp_off block
- = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
-
+maybeAddSpAdj dflags sp_off block = block `blockSnoc` adj
+ where
+ adj = CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
{-
Sp(L) is the Sp offset on entry to block L relative to the base of the
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 1103fdb6ec..7acf4c6d8b 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -61,7 +61,9 @@ data CmmNode e x where
-- 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
+ --
+ -- See Note [What is this unwinding business?] in Debug
+ CmmUnwind :: [(GlobalReg, CmmExpr)] -> CmmNode O O
CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
-- Assign to register
@@ -459,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 r e) = CmmUnwind r (f e)
+mapExp f (CmmUnwind regs) = CmmUnwind (map (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)
@@ -490,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 r e) = CmmUnwind r `fmap` f e
+mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> 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
@@ -543,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 _ e) z = f e z
+foldExp f (CmmUnwind xs) z = foldr 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 e7425930a6..cfadc61e84 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -635,8 +635,15 @@ stmt :: { CmmParse () }
{ pushStackFrame $3 $5 }
| 'reserve' expr '=' lreg maybe_body
{ reserveStackFrame $2 $4 $5 }
- | 'unwind' GLOBALREG '=' expr
- { $4 >>= code . emitUnwind $2 }
+ | 'unwind' unwind_regs ';'
+ { $2 >>= code . emitUnwind }
+
+unwind_regs
+ :: { CmmParse [(GlobalReg, CmmExpr)] }
+ : GLOBALREG '=' expr ',' unwind_regs
+ { do e <- $3; rest <- $5; return (($1, e) : rest) }
+ | GLOBALREG '=' expr
+ { do e <- $3; return [($1, 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 7b9383569b..02daa3686c 100644
--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -12,15 +12,17 @@
module Debug (
DebugBlock(..), dblIsEntry,
- UnwindTable, UnwindExpr(..),
cmmDebugGen,
cmmDebugLabels,
cmmDebugLink,
- debugToMap
+ debugToMap,
+ -- * Unwinding information
+ UnwindTable, UnwindPoint(..),
+ UnwindExpr(..), toUnwindExpr
) where
-import BlockId ( blockLbl )
+import BlockId
import CLabel
import Cmm
import CmmUtils
@@ -56,7 +58,7 @@ data DebugBlock =
, dblPosition :: !(Maybe Int) -- ^ Output position relative to
-- other blocks. @Nothing@ means
-- the block was optimized out
- , dblUnwind :: !UnwindTable -- ^ Unwind information
+ , dblUnwind :: [UnwindPoint]
, dblBlocks :: ![DebugBlock] -- ^ Nested blocks
}
@@ -74,14 +76,12 @@ instance Outputable DebugBlock where
(maybe empty ppr (dblSourceTick blk)) <+>
(maybe (text "removed") ((text "pos " <>) . ppr)
(dblPosition blk)) <+>
- pprUwMap (dblUnwind blk) $$
+ (ppr (dblUnwind blk)) <+>
(if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
- where pprUw (g, expr) = ppr g <> char '=' <> ppr expr
- pprUwMap = braces . hsep . punctuate comma . map pprUw . Map.toList
-- | Intermediate data structure holding debug-relevant context information
-- about a block.
-type BlockContext = (CmmBlock, RawCmmDecl, UnwindTable)
+type BlockContext = (CmmBlock, RawCmmDecl)
-- | Extract debug data from a group of procedures. We will prefer
-- source notes that come from the given module (presumably the module
@@ -127,7 +127,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
| otherwise = panic "ticksToCopy impossible"
where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
ticksToCopy _ = []
- bCtxsTicks = concatMap (blockTicks . fstOf3)
+ bCtxsTicks = concatMap (blockTicks . fst)
-- Finding the "best" source tick is somewhat arbitrary -- we
-- select the first source span, while preferring source ticks
@@ -151,7 +151,9 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
nested = fromMaybe [] $ Map.lookup scope scopeMap
childs = map (mkBlock False) (tail bctxs) ++
map (blocksForScope stick) nested
- mkBlock top (block, prc, unwind)
+
+ mkBlock :: Bool -> BlockContext -> DebugBlock
+ mkBlock top (block, prc)
= DebugBlock { dblProcedure = g_entry graph
, dblLabel = label
, dblCLabel = case info of
@@ -163,9 +165,9 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
, dblParent = Nothing
, dblTicks = ticks
, dblPosition = Nothing -- see cmmDebugLink
- , dblUnwind = unwind
, dblSourceTick = stick
, dblBlocks = blocks
+ , dblUnwind = []
}
where (CmmProc infos entryLbl _ graph) = prc
label = entryLabel block
@@ -189,29 +191,33 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
--
-- This involves a pre-order traversal, as we want blocks in rough
-- control flow order (so ticks have a chance to be sorted in the
--- right order). We also use this opportunity to have blocks inherit
--- unwind information from their predecessor blocks where it is
--- lacking.
+-- right order).
blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
- where walkProc CmmData{} m = m
+ where walkProc :: RawCmmDecl
+ -> Map.Map CmmTickScope [BlockContext]
+ -> Map.Map CmmTickScope [BlockContext]
+ walkProc CmmData{} m = m
walkProc prc@(CmmProc _ _ _ graph) m
| mapNull blocks = m
- | otherwise = snd $ walkBlock prc entry Map.empty (emptyLbls, m)
+ | otherwise = snd $ walkBlock prc entry (emptyLbls, m)
where blocks = toBlockMap graph
entry = [mapFind (g_entry graph) blocks]
emptyLbls = setEmpty :: LabelSet
- walkBlock _ [] _ c = c
- walkBlock prc (block:blocks) unwind (visited, m)
+
+ walkBlock :: RawCmmDecl -> [Block CmmNode C C]
+ -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+ -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+ walkBlock _ [] c = c
+ walkBlock prc (block:blocks) (visited, m)
| lbl `setMember` visited
- = walkBlock prc blocks unwind (visited, m)
+ = walkBlock prc blocks (visited, m)
| otherwise
- = walkBlock prc blocks unwind $
- walkBlock prc succs unwind'
+ = walkBlock prc blocks $
+ walkBlock prc succs
(lbl `setInsert` visited,
- insertMulti scope (block, prc, unwind') m)
+ insertMulti scope (block, prc) m)
where CmmEntry lbl scope = firstNode block
- unwind' = extractUnwind block `Map.union` unwind
(CmmProc _ _ _ graph) = prc
succs = map (flip mapFind (toBlockMap graph))
(successors (lastNode block))
@@ -234,14 +240,17 @@ cmmDebugLabels isMeta nats = seqList lbls lbls
getBlocks _other = []
allMeta (BasicBlock _ instrs) = all isMeta instrs
--- | Sets position fields in the debug block tree according to native
--- generated code.
-cmmDebugLink :: [Label] -> [DebugBlock] -> [DebugBlock]
-cmmDebugLink labels blocks = map link blocks
+-- | Sets position and unwind table fields in the debug block tree according to
+-- native generated code.
+cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
+ -> [DebugBlock] -> [DebugBlock]
+cmmDebugLink labels unwindPts blocks = map link blocks
where blockPos :: LabelMap Int
blockPos = mapFromList $ flip zip [0..] labels
link block = block { dblPosition = mapLookup (dblLabel block) blockPos
, dblBlocks = map link (dblBlocks block)
+ , dblUnwind = fromMaybe mempty
+ $ mapLookup (dblLabel block) unwindPts
}
-- | Converts debug blocks into a label map for easier lookups
@@ -249,14 +258,158 @@ debugToMap :: [DebugBlock] -> LabelMap DebugBlock
debugToMap = mapUnions . map go
where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
+{-
+Note [What is this unwinding business?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwinding tables are a variety of debugging information used by debugging tools
+to reconstruct the execution history of a program at runtime. These tables
+consist of sets of "instructions", one set for every instruction in the program,
+which describe how to reconstruct the state of the machine at the point where
+the current procedure was called. For instance, consider the following annotated
+pseudo-code,
+
+ a_fun:
+ add rsp, 8 -- unwind: rsp = rsp - 8
+ mov rax, 1 -- unwind: rax = unknown
+ call another_block
+ sub rsp, 8 -- unwind: rsp = rsp
+
+We see that attached to each instruction there is an "unwind" annotation, which
+provides a relationship between each updated register and its value at the
+time of entry to a_fun. This is the sort of information that allows gdb to give
+you a stack backtrace given the execution state of your program. This
+unwinding information is captured in various ways by various debug information
+formats; in the case of DWARF (the only format supported by GHC) it is known as
+Call Frame Information (CFI) and can be found in the .debug.frames section of
+your object files.
+
+Currently we only bother to produce unwinding information for registers which
+are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp
+(which is the STG stack pointer) and $rsp (the C stack pointer).
+
+Let's consider how GHC would annotate a C-- program with unwinding information
+with a typical C-- procedure as would come from the STG-to-Cmm code generator,
+
+ entry()
+ { c2fe:
+ v :: P64 = R2;
+ if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+ c2ff:
+ R2 = v :: P64;
+ R1 = test_closure;
+ call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+ c2fg:
+ I64[Sp - 8] = c2dD;
+ R1 = v :: P64;
+ Sp = Sp - 8; // Sp updated here
+ if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+ c2dE:
+ call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+ c2dD:
+ w :: P64 = R1;
+ Hp = Hp + 48;
+ if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+ ...
+ },
+
+Let's consider how this procedure will be decorated with unwind information
+(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the
+value of Sp is no different from what it was at its call site. Therefore we will
+add an `unwind` statement saying this at the beginning of its unwind-annotated
+code,
+
+ entry()
+ { c2fe:
+ unwind Sp = Just Sp + 0;
+ v :: P64 = R2;
+ if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+
+After c2fe we we may pass to either c2ff or c2fg; let's first consider the
+former. In this case there is nothing in particular that we need to do other
+than reiterate what we already know about Sp,
+
+ c2ff:
+ unwind Sp = Just Sp + 0;
+ R2 = v :: P64;
+ R1 = test_closure;
+ call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+
+In contrast, c2fg updates Sp midway through its body. To ensure that unwinding
+can happen correctly after this point we must include an unwind statement there,
+in addition to the usual beginning-of-block statement,
+
+ c2fg:
+ unwind Sp = Just Sp + 0;
+ I64[Sp - 8] = c2dD;
+ R1 = v :: P64;
+ unwind Sp = Just Sp + 8;
+ Sp = Sp - 8;
+ if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+
+The remaining blocks are simple,
+
+ c2dE:
+ unwind Sp = Just Sp + 8;
+ call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+ c2dD:
+ unwind Sp = Just Sp + 8;
+ w :: P64 = R1;
+ Hp = Hp + 48;
+ if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+ ...
+ },
+
+
+The flow of unwinding information through the compiler is a bit convoluted:
+
+ * C-- begins life in StgCmm without any unwind information. This is because we
+ haven't actually done any register assignment or stack layout yet, so there
+ is no need for unwind information.
+
+ * CmmLayoutStack figures out how to layout each procedure's stack, and produces
+ appropriate unwinding nodes for each adjustment of the STG Sp register.
+
+ * The unwind nodes are carried through the sinking pass. Currently this is
+ guaranteed not to invalidate unwind information since it won't touch stores
+ to Sp, but this will need revisiting if CmmSink gets smarter in the future.
+
+ * Eventually we make it to the native code generator backend which can then
+ preserve the unwind nodes in its machine-specific instructions. In so doing
+ the backend can also modify or add unwinding information; this is necessary,
+ for instance, in the case of x86-64, where adjustment of $rsp may be
+ necessary during calls to native foreign code due to the native calling
+ convention.
+
+ * The NCG then retrieves the final unwinding table for each block from the
+ backend with extractUnwindPoints.
+
+ * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen
+
+ * These DebugBlcosk are then converted to, e.g., DWARF unwinding tables
+ (by the Dwarf module) and emitted in the final object.
+
+See also: Note [Unwinding information in the NCG] in AsmCodeGen.
+-}
+
+-- | A label associated with an 'UnwindTable'
+data UnwindPoint = UnwindPoint !Label !UnwindTable
+
+instance Outputable UnwindPoint where
+ ppr (UnwindPoint lbl uws) =
+ braces $ ppr lbl<>colon
+ <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
+ 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
-- | Expressions, used for unwind information
-data UnwindExpr = UwConst Int -- ^ literal value
- | UwReg GlobalReg Int -- ^ register plus offset
+data UnwindExpr = UwConst !Int -- ^ literal value
+ | UwReg !GlobalReg !Int -- ^ register plus offset
| UwDeref UnwindExpr -- ^ pointer dereferencing
| UwLabel CLabel
| UwPlus UnwindExpr UnwindExpr
@@ -278,17 +431,6 @@ instance Outputable UnwindExpr where
= pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
pprPrec _ other = parens (pprPrec 0 other)
-extractUnwind :: CmmBlock -> UnwindTable
-extractUnwind b = go $ blockToList mid
- where (_, mid, _) = blockSplit b
- go :: [CmmNode O O] -> UnwindTable
- go [] = Map.empty
- go (x : xs) = case x of
- CmmUnwind g so -> Map.insert g (toUnwindExpr so) $! go xs
- CmmTick {} -> go xs
- _other -> Map.empty
- -- TODO: Unwind statements after actual instructions
-
-- | Conversion of Cmm expressions to unwind expressions. We check for
-- unsupported operator usages and simplify the expression as far as
-- possible.
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index ae7c5097af..ed795a1d3e 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -14,6 +14,7 @@ module MkGraph
, mkRawJump
, mkCbranch, mkSwitch
, mkReturn, mkComment, mkCallEntry, mkBranch
+ , mkUnwind
, copyInOflow, copyOutOflow
, noExtraStack
, toCall, Transfer(..)
@@ -270,6 +271,8 @@ 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
+mkUnwind :: GlobalReg -> CmmExpr -> CmmAGraph
+mkUnwind r e = mkMiddle $ CmmUnwind [(r, e)]
--------------------------------------------------------------------------
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 9517ea3c09..089066a1ab 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -197,7 +197,9 @@ pprNode node = pp_node <+> pp_debug
else empty
-- unwind reg = expr;
- CmmUnwind r e -> text "unwind " <> ppr r <+> char '=' <+> ppr e
+ CmmUnwind regs ->
+ text "unwind "
+ <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
-- reg = expr;
CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index a19731295a..d8f268d2bd 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -84,10 +84,10 @@ baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags
baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
-baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg"
-baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg"
-baseRegOffset _ MachSp = panic "baseRegOffset:MachSp"
-baseRegOffset _ UnwindReturnReg = panic "baseRegOffset:UnwindReturnReg"
+baseRegOffset _ BaseReg = panic "CgUtils.baseRegOffset:BaseReg"
+baseRegOffset _ PicBaseReg = panic "CgUtils.baseRegOffset:PicBaseReg"
+baseRegOffset _ MachSp = panic "CgUtils.baseRegOffset:MachSp"
+baseRegOffset _ UnwindReturnReg = panic "CgUtils.baseRegOffset:UnwindReturnReg"
-- -----------------------------------------------------------------------------
@@ -137,7 +137,11 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
fixAssign stmt =
case stmt of
- CmmAssign (CmmGlobal reg) src ->
+ CmmAssign (CmmGlobal reg) src
+ -- MachSp isn't an STG register; it's merely here for tracking unwind
+ -- information
+ | reg == MachSp -> stmt
+ | otherwise ->
let baseAddr = get_GlobalReg_addr dflags reg
in case reg `elem` activeStgRegs (targetPlatform dflags) of
True -> CmmAssign (CmmGlobal reg) src
@@ -145,6 +149,8 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
other_stmt -> other_stmt
fixExpr expr = case expr of
+ -- MachSp isn't an STG; it's merely here for tracking unwind information
+ CmmReg (CmmGlobal MachSp) -> expr
CmmReg (CmmGlobal reg) ->
-- Replace register leaves with appropriate StixTrees for
-- the given target. MagicIds which map to a reg on this
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index fadf5ab5a9..c5ad73da4d 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -735,11 +735,11 @@ emitComment _ = return ()
emitTick :: CmmTickish -> FCode ()
emitTick = emitCgStmt . CgStmt . CmmTick
-emitUnwind :: GlobalReg -> CmmExpr -> FCode ()
-emitUnwind g e = do
+emitUnwind :: [(GlobalReg, CmmExpr)] -> FCode ()
+emitUnwind regs = do
dflags <- getDynFlags
- when (debugLevel dflags > 0) $
- emitCgStmt $ CgStmt $ CmmUnwind g e
+ when (debugLevel dflags > 0) $ do
+ emitCgStmt $ CgStmt $ CmmUnwind regs
emitAssign :: CmmReg -> CmmExpr -> FCode ()
emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 295ac15a85..2a00379ee5 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -298,7 +298,7 @@ baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
-baseRegOffset _ reg = pprPanic "baseRegOffset:" (ppr reg)
+baseRegOffset _ reg = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg)
-------------------------------------------------------------------------
--
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 7cc7a2804d..b4752cce0c 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -162,7 +162,13 @@ data NcgImpl statics instr jumpDest = NcgImpl {
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),
- ncgMakeFarBranches :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr]
+ ncgMakeFarBranches :: LabelMap CmmStatics
+ -> [NatBasicBlock instr] -> [NatBasicBlock instr],
+ extractUnwindPoints :: [instr] -> [UnwindPoint]
+ -- ^ given the instruction sequence of a block, produce a list of
+ -- the block's 'UnwindPoint's
+ -- See Note [What is this unwinding business?] in Debug
+ -- and Note [Unwinding information in the NCG] in this module.
}
--------------------
@@ -209,6 +215,7 @@ x86_64NcgImpl dflags
,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = const id
+ ,extractUnwindPoints = X86.CodeGen.extractUnwindPoints
}
where platform = targetPlatform dflags
@@ -228,6 +235,7 @@ ppcNcgImpl dflags
,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = PPC.Instr.makeFarBranches
+ ,extractUnwindPoints = const []
}
where platform = targetPlatform dflags
@@ -247,6 +255,7 @@ sparcNcgImpl dflags
,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = const id
+ ,extractUnwindPoints = const []
}
--
@@ -279,8 +288,36 @@ data NativeGenAcc statics instr
, ngs_labels :: ![Label]
, ngs_debug :: ![DebugBlock]
, ngs_dwarfFiles :: !DwarfFiles
+ , ngs_unwinds :: !(LabelMap [UnwindPoint])
+ -- ^ see Note [Unwinding information in the NCG]
+ -- and Note [What is this unwinding business?] in Debug.
}
+{-
+Note [Unwinding information in the NCG]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwind information is a type of metadata which allows a debugging tool
+to reconstruct the values of machine registers at the time a procedure was
+entered. For the most part, the production of unwind information is handled by
+the Cmm stage, where it is represented by CmmUnwind nodes.
+
+Unfortunately, the Cmm stage doesn't know everything necessary to produce
+accurate unwinding information. For instance, the x86-64 calling convention
+requires that the stack pointer be aligned to 16 bytes, which in turn means that
+GHC must sometimes add padding to $sp prior to performing a foreign call. When
+this happens unwind information must be updated accordingly.
+For this reason, we make the NCG backends responsible for producing
+unwinding tables (with the extractUnwindPoints function in NcgImpl).
+
+We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds
+field of NativeGenAcc. This is a label map which contains an entry for each
+procedure, containing a list of unwinding points (e.g. a label and an associated
+unwinding table).
+
+See also Note [What is this unwinding business?] in Debug.
+-}
+
nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> Module -> ModLocation
@@ -295,7 +332,7 @@ nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h
- let ngs0 = NGS [] [] [] [] [] [] emptyUFM
+ let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
(ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
cmms ngs0
finishNativeGen dflags modLoc bufh us' ngs
@@ -386,11 +423,12 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
ofBlockList (panic "split_marker_entry") []
cmms' | splitObjs = split_marker : cmms
| otherwise = cmms
- (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
- cmms' ngs 0
+ (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+ dbgMap us cmms' ngs 0
-- Link native code information into debug blocks
- let !ldbgs = cmmDebugLink (ngs_labels ngs') ndbgs
+ -- See Note [What is this unwinding business?] in Debug.
+ let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
(vcat $ map ppr ldbgs)
@@ -430,7 +468,8 @@ cmmNativeGens :: forall statics instr jumpDest.
cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
where
- go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int
+ go :: UniqSupply -> [RawCmmDecl]
+ -> NativeGenAcc statics instr -> Int
-> IO (NativeGenAcc statics instr, UniqSupply)
go us [] ngs !_ =
@@ -438,7 +477,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
go us (cmm : cmms) ngs count = do
let fileIds = ngs_dwarfFiles ngs
- (us', fileIds', native, imports, colorStats, linearStats)
+ (us', fileIds', native, imports, colorStats, linearStats, unwinds)
<- {-# SCC "cmmNativeGen" #-}
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
cmm count
@@ -463,6 +502,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
then cmmDebugLabels isMetaInstr native else []
!natives' = if dopt Opt_D_dump_asm_stats dflags
then native : ngs_natives ngs else []
+
mCon = maybe id (:)
ngs' = ngs{ ngs_imports = imports : ngs_imports ngs
, ngs_natives = natives'
@@ -470,6 +510,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
, ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
, ngs_labels = ngs_labels ngs ++ labels'
, ngs_dwarfFiles = fileIds'
+ , ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds
}
go us' cmms ngs' (count + 1)
@@ -506,7 +547,9 @@ cmmNativeGen
, [NatCmmDecl statics instr] -- native code
, [CLabel] -- things imported by this cmm
, Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
- , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
+ , Maybe [Linear.RegAllocStats] -- stats for the linear register allocators
+ , LabelMap [UnwindPoint] -- unwinding information for blocks
+ )
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= do
@@ -659,12 +702,22 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
(vcat $ map (pprNatCmmDecl ncgImpl) expanded)
+ -- generate unwinding information from cmm
+ let unwinds :: BlockMap [UnwindPoint]
+ unwinds =
+ {-# SCC "unwindingInfo" #-}
+ foldl' addUnwind mapEmpty expanded
+ where
+ addUnwind acc proc =
+ acc `mapUnion` computeUnwinding dflags ncgImpl proc
+
return ( usAlloc
, fileIds'
, expanded
, lastMinuteImports ++ imports
, ppr_raStatsColor
- , ppr_raStatsLinear)
+ , ppr_raStatsLinear
+ , unwinds )
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
@@ -672,6 +725,28 @@ x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge (CmmProc info lbl live (ListGraph code)) =
CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)
+-- | Compute unwinding tables for the blocks of a procedure
+computeUnwinding :: Instruction instr
+ => DynFlags -> NcgImpl statics instr jumpDest
+ -> NatCmmDecl statics instr
+ -- ^ the native code generated for the procedure
+ -> LabelMap [UnwindPoint]
+ -- ^ unwinding tables for all points of all blocks of the
+ -- procedure
+computeUnwinding dflags _ _
+ | debugLevel dflags == 0 = mapEmpty
+computeUnwinding _ _ (CmmData _ _) = mapEmpty
+computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
+ -- In general we would need to push unwinding information down the
+ -- block-level call-graph to ensure that we fully account for all
+ -- relevant register writes within a procedure.
+ --
+ -- However, the only unwinding information that we care about in GHC is for
+ -- Sp. The fact that CmmLayoutStack already ensures that we have unwind
+ -- information at the beginning of every block means that there is no need
+ -- to perform this sort of push-down.
+ mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
+ | BasicBlock blk_lbl instrs <- blks ]
-- | Build a doc for all the imports.
--
@@ -928,6 +1003,9 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
-- the beginning of the block. For stacks which grow down, this value
-- should be either zero or negative.
+-- Along with the stack pointer offset, we also carry along a LabelMap of
+-- DebugBlocks, which we read to generate .location directives.
+--
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index 3b299746a9..1aabd72164 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -17,6 +17,7 @@ import UniqSupply
import Dwarf.Constants
import Dwarf.Types
+import Control.Arrow ( first )
import Control.Monad ( mfilter )
import Data.Maybe
import Data.List ( sortBy )
@@ -215,20 +216,42 @@ procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
procToFrame initUws blk
= DwarfFrameProc { dwFdeProc = dblCLabel blk
, dwFdeHasInfo = dblHasInfoTbl blk
- , dwFdeBlocks = map (uncurry blockToFrame) blockUws
+ , dwFdeBlocks = map (uncurry blockToFrame)
+ (setHasInfo blockUws)
}
- where blockUws :: [(DebugBlock, UnwindTable)]
- blockUws = map snd $ sortBy (comparing fst) $ flatten initUws blk
- flatten uws0 b@DebugBlock{ dblPosition=pos, dblUnwind=uws,
- dblBlocks=blocks }
+ where blockUws :: [(DebugBlock, [UnwindPoint])]
+ blockUws = map snd $ sortBy (comparing fst) $ flatten blk
+
+ flatten :: DebugBlock
+ -> [(Int, (DebugBlock, [UnwindPoint]))]
+ flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
| Just p <- pos = (p, (b, uws')):nested
| otherwise = nested -- block was optimized out
- where uws' = uws `Map.union` uws0
- nested = concatMap (flatten uws') blocks
+ where uws' = addDefaultUnwindings initUws uws
+ nested = concatMap flatten blocks
+
+ -- | If the current procedure has an info table, then we also say that
+ -- its first block has one to ensure that it gets the necessary -1
+ -- offset applied to its start address.
+ -- See Note [Info Offset] in Dwarf.Types.
+ setHasInfo :: [(DebugBlock, [UnwindPoint])]
+ -> [(DebugBlock, [UnwindPoint])]
+ setHasInfo [] = []
+ setHasInfo (c0:cs) = first setIt c0 : cs
+ where
+ setIt child =
+ child { dblHasInfoTbl = dblHasInfoTbl child
+ || dblHasInfoTbl blk }
-blockToFrame :: DebugBlock -> UnwindTable -> DwarfFrameBlock
+blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
blockToFrame blk uws
- = DwarfFrameBlock { dwFdeBlock = mkAsmTempLabel $ dblLabel blk
- , dwFdeBlkHasInfo = dblHasInfoTbl blk
+ = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
, dwFdeUnwind = uws
}
+
+addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
+addDefaultUnwindings tbl pts =
+ [ UnwindPoint lbl (tbl' `mappend` tbl)
+ -- mappend is left-biased
+ | UnwindPoint lbl tbl' <- pts
+ ]
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
index 0fcd926c53..c1a866fe19 100644
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -35,8 +35,9 @@ import SrcLoc
import Dwarf.Constants
+import qualified Control.Monad.Trans.State.Strict as S
+import Control.Monad (zipWithM)
import Data.Bits
-import Data.List ( mapAccumL )
import qualified Data.Map as Map
import Data.Word
import Data.Char
@@ -268,11 +269,15 @@ data DwarfFrameProc
-- containing FDE.
data DwarfFrameBlock
= DwarfFrameBlock
- { dwFdeBlock :: CLabel
- , dwFdeBlkHasInfo :: Bool
- , dwFdeUnwind :: UnwindTable
+ { dwFdeBlkHasInfo :: Bool
+ , dwFdeUnwind :: [UnwindPoint]
+ -- ^ these unwind points must occur in the same order as they occur
+ -- in the block
}
+instance Outputable DwarfFrameBlock where
+ ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds
+
-- | Header for the @.debug_frame@ section. Here we emit the "Common
-- Information Entry" record that etablishes general call frame
-- parameters and the default stack layout.
@@ -285,6 +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 (g, uw) = pprSetUnwind plat g (Nothing, uw)
-- Preserve C stack pointer: This necessary to override that default
@@ -337,7 +343,8 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
procEnd = mkAsmTempEndLabel procLbl
ifInfo str = if hasInfo then text str else empty
-- see [Note: Info Offset]
- in vcat [ pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
+ in vcat [ ifPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
+ , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
, ppr fdeLabel <> colon
, pprData4' (ppr frameLbl <> char '-' <>
ptext dwarfFrameLabel) -- Reference to CIE
@@ -345,7 +352,7 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
, pprWord (ppr procEnd <> char '-' <>
ppr procLbl <> ifInfo "+1") -- Block byte length
] $$
- vcat (snd $ mapAccumL pprFrameBlock initUw blocks) $$
+ vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
wordAlign $$
ppr fdeEndLabel <> colon
@@ -353,22 +360,29 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
-- instructions where unwind information actually changes. This small
-- optimisations saves a lot of space, as subsequent blocks often have
-- the same unwind information.
-pprFrameBlock :: UnwindTable -> DwarfFrameBlock -> (UnwindTable, SDoc)
-pprFrameBlock oldUws (DwarfFrameBlock blockLbl hasInfo uws)
- | uws == oldUws
- = (oldUws, empty)
- | otherwise
- = (,) uws $ sdocWithPlatform $ \plat ->
- let lbl = ppr blockLbl <> if hasInfo then text "-1" else empty
- -- see [Note: Info Offset]
- isChanged g v | old == Just v = Nothing
- | otherwise = Just (old, v)
- where old = Map.lookup g oldUws
- changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
- died = Map.toList $ Map.difference oldUws uws
- in pprByte dW_CFA_set_loc $$ pprWord lbl $$
- vcat (map (uncurry $ pprSetUnwind plat) changed) $$
- vcat (map (pprUndefUnwind plat . fst) died)
+pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
+pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
+ vcat <$> zipWithM pprFrameDecl (True : repeat False) 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
+ changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
+ died = Map.toList $ Map.difference oldUws uws
+
+ in if oldUws == uws
+ then (empty, oldUws)
+ else let -- see [Note: Info Offset]
+ needsOffset = firstDecl && hasInfo
+ lblDoc = ppr lbl <>
+ 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)
+ in (doc, uws)
-- Note [Info Offset]
--
@@ -442,7 +456,7 @@ pprUnwindExpr spIsCFA expr
pprE (UwReg Sp i) | spIsCFA
= if i == 0
then pprByte dW_OP_call_frame_cfa
- else ppr (UwPlus (UwReg Sp 0) (UwConst i))
+ else pprE (UwPlus (UwReg Sp 0) (UwConst i))
pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
pprLEBInt i
pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index ca5bafe63a..34aaa17701 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -85,7 +85,6 @@ initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m
= case unNat m init_st of { (r,st) -> (r,st) }
-
instance Functor NatM where
fmap = liftM
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index b60d61047f..b1f11e4bf9 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -21,6 +21,7 @@
module X86.CodeGen (
cmmTopCodeGen,
generateJumpTableForInstr,
+ extractUnwindPoints,
InstrBlock
)
@@ -37,7 +38,8 @@ import X86.Regs
import X86.RegInfo
import CodeGen.Platform
import CPrim
-import Debug ( DebugBlock(..) )
+import Debug ( DebugBlock(..), UnwindPoint(..), UnwindTable
+ , UnwindExpr(UwReg), toUnwindExpr )
import Instruction
import PIC
import NCGMonad
@@ -69,10 +71,13 @@ import Util
import Control.Monad
import Data.Bits
+import Data.Foldable (fold)
import Data.Int
import Data.Maybe
import Data.Word
+import qualified Data.Map as M
+
is32BitPlatform :: NatM Bool
is32BitPlatform = do
dflags <- getDynFlags
@@ -134,12 +139,13 @@ basicBlockCodeGen block = do
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
+ instrs' <- fold <$> traverse addSpUnwindings instrs
-- code generation may introduce new basic block boundaries, which
-- are indicated by the NEWBLOCK instruction. We must split up the
-- instruction stream into basic blocks again. Also, we extract
-- LDATAs here too.
let
- (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+ (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'
mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
= ([], BasicBlock id instrs : blocks, statics)
@@ -149,6 +155,18 @@ basicBlockCodeGen block = do
= (instr:instrs, blocks, statics)
return (BasicBlock id top : other_blocks, statics)
+-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes
+-- in the @sp@ register. See Note [What is this unwinding business?] in Debug
+-- for details.
+addSpUnwindings :: Instr -> NatM (OrdList Instr)
+addSpUnwindings instr@(DELTA d) = do
+ dflags <- getDynFlags
+ if debugLevel dflags >= 1
+ then do lbl <- newBlockId
+ let unwind = M.singleton MachSp (UwReg MachSp $ negate d)
+ return $ toOL [ instr, UNWIND lbl unwind ]
+ else return (unitOL instr)
+addSpUnwindings instr = return $ unitOL instr
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs stmts
@@ -163,7 +181,15 @@ stmtToInstrs stmt = do
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
- CmmUnwind {} -> return nilOL
+
+ CmmUnwind regs -> do
+ let to_unwind_entry :: (GlobalReg, CmmExpr) -> UnwindTable
+ to_unwind_entry (reg, expr) = M.singleton reg (toUnwindExpr expr)
+ case foldMap to_unwind_entry regs of
+ tbl | M.null tbl -> return nilOL
+ | otherwise -> do
+ lbl <- newBlockId
+ return $ unitOL $ UNWIND lbl tbl
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode format reg src
@@ -2264,8 +2290,7 @@ genCCall32' dflags target dest_regs args = do
ChildCode64 code r_lo <- iselExpr64 arg
delta <- getDeltaNat
setDeltaNat (delta - 8)
- let
- r_hi = getHiVRegFromLo r_lo
+ let r_hi = getHiVRegFromLo r_lo
return ( code `appOL`
toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
PUSH II32 (OpReg r_lo), DELTA (delta - 8),
@@ -2713,6 +2738,10 @@ createJumpTable dflags ids section lbl
| otherwise = map (jumpTableEntry dflags) ids
in CmmData section (1, Statics lbl jumpTable)
+extractUnwindPoints :: [Instr] -> [UnwindPoint]
+extractUnwindPoints instrs =
+ [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]
+
-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 0fabf71cfd..4b43a1cf27 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -39,6 +39,7 @@ import DynFlags
import UniqSet
import Unique
import UniqSupply
+import Debug (UnwindTable)
import Control.Monad
import Data.Maybe (fromMaybe)
@@ -179,9 +180,13 @@ data Instr
-- invariants for a BasicBlock (see Cmm).
| NEWBLOCK BlockId
- -- specify current stack offset for
- -- benefit of subsequent passes
- | DELTA Int
+ -- unwinding information
+ -- See Note [Unwinding information in the NCG].
+ | UNWIND BlockId UnwindTable
+
+ -- specify current stack offset for benefit of subsequent passes.
+ -- This carries a BlockId so it can be used in unwinding information.
+ | DELTA Int
-- Moves.
| MOV Format Operand Operand
@@ -448,6 +453,7 @@ x86_regUsageOfInstr platform instr
COMMENT _ -> noUsage
LOCATION{} -> noUsage
+ UNWIND{} -> noUsage
DELTA _ -> noUsage
POPCNT _ src dst -> mkRU (use_R src []) [dst]
@@ -621,6 +627,7 @@ x86_patchRegsOfInstr instr env
NOP -> instr
COMMENT _ -> instr
LOCATION {} -> instr
+ UNWIND {} -> instr
DELTA _ -> instr
JXX _ _ -> instr
@@ -784,6 +791,7 @@ x86_isMetaInstr instr
LOCATION{} -> True
LDATA{} -> True
NEWBLOCK{} -> True
+ UNWIND{} -> True
DELTA{} -> True
_ -> False
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index f4ca20987a..1864fc1ba8 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -514,23 +514,27 @@ pprDataItem' dflags lit
= panic "X86.Ppr.ppr_item: no match"
+asmComment :: SDoc -> SDoc
+asmComment c = ifPprDebug $ text "# " <> c
pprInstr :: Instr -> SDoc
-pprInstr (COMMENT _) = empty -- nuke 'em
-{-
-pprInstr (COMMENT s) = text "# " <> ftext s
--}
+pprInstr (COMMENT s)
+ = asmComment (ftext s)
pprInstr (LOCATION file line col _name)
= text "\t.loc " <> ppr file <+> ppr line <+> ppr col
pprInstr (DELTA d)
- = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+ = asmComment $ text ("\tdelta = " ++ show d)
pprInstr (NEWBLOCK _)
= panic "PprMach.pprInstr: NEWBLOCK"
+pprInstr (UNWIND lbl d)
+ = asmComment (text "\tunwind = " <> ppr d)
+ $$ ppr lbl <> colon
+
pprInstr (LDATA _ _)
= panic "PprMach.pprInstr: LDATA"
diff --git a/rts/StgStartup.cmm b/rts/StgStartup.cmm
index aad4fab139..a3a75d8211 100644
--- a/rts/StgStartup.cmm
+++ b/rts/StgStartup.cmm
@@ -70,8 +70,8 @@ INFO_TABLE_RET(stg_stop_thread, STOP_FRAME,
for us by StgRun.
*/
#ifdef x86_64_HOST_ARCH
- unwind MachSp = MachSp + RESERVED_C_STACK_BYTES + 0x38 + 8
- unwind UnwindReturnReg = W_[MachSp + RESERVED_C_STACK_BYTES + 0x38]
+ unwind MachSp = MachSp + RESERVED_C_STACK_BYTES + 0x38 + 8,
+ UnwindReturnReg = W_[MachSp + RESERVED_C_STACK_BYTES + 0x38];
#endif
Sp = Sp + SIZEOF_StgStopFrame - WDS(2);
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index 5412b62ab1..9a9a640d5d 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -123,7 +123,7 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do
mapM (\ (count, thisCmm) ->
cmmNativeGen dflags thisMod thisModLoc ncgImpl
usb dwarfFileIds dbgMap thisCmm count >>=
- (\(_, _, _, _, colorStats, linearStats) ->
+ (\(_, _, _, _, colorStats, linearStats, _) ->
-- scrub unneeded output from cmmNativeGen
return (colorStats, linearStats)))
$ zip [0.. (length collectedCmms)] collectedCmms
View Lorry Controller Status