diff options
40 files changed, 886 insertions, 205 deletions
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 58d4ec91f3..2aa1eefb4b 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -3648,19 +3648,9 @@ primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp out_of_line = True primtype StackSnapshot# - -primop CloneMyStack "cloneMyStack#" GenPrimOp - State# RealWorld -> (# State# RealWorld, StackSnapshot# #) - { Clones the stack of the current (active) Haskell thread. A cloned stack is - represented by {\tt StackSnapshot# } and is not evaluated any further - (i.e. it's "cold"). This is useful for stack decoding (backtraces) and - analyses because there are no concurrent mutations on a cloned stack. - The module {\tt GHC.Stack.CloneStack } contains related funcions. - Please see Note [Stack Cloning] for technical details. } - with - has_side_effects = True - out_of_line = True - + { Haskell representation of a {\tt StgStack*} that was created (cloned) + with a function in {\tt GHC.Stack.CloneStack}. Please check the + documentation in this module for more detailed explanations. } ------------------------------------------------------------------------ section "Safe coercions" diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index 3a461fa03c..893ca556db 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -167,12 +167,12 @@ data CmmInfoTable -- place to convey this information from the code generator to -- where we build the static closures in -- GHC.Cmm.Info.Build.doSRTs. - } + } deriving Eq data ProfilingInfo = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc - + deriving Eq ----------------------------------------------------------------------------- -- Static Data ----------------------------------------------------------------------------- @@ -288,4 +288,3 @@ instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) - diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs index 0f846bad1b..455a7d639a 100644 --- a/compiler/GHC/Cmm/Ppr.hs +++ b/compiler/GHC/Cmm/Ppr.hs @@ -64,6 +64,8 @@ import GHC.Cmm.Dataflow.Graph ------------------------------------------------- -- Outputable instances +instance OutputableP Platform InfoProvEnt where + pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel instance Outputable CmmStackInfo where ppr = pprStackInfo diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs new file mode 100644 index 0000000000..e0b0deaa83 --- /dev/null +++ b/compiler/GHC/Driver/GenerateCgIPEStub.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE GADTs #-} + +module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where + +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, listToMaybe) +import GHC.Cmm +import GHC.Cmm.CLabel (CLabel) +import GHC.Cmm.Dataflow (Block, C, O) +import GHC.Cmm.Dataflow.Block (blockSplit, blockToList) +import GHC.Cmm.Dataflow.Collections (mapToList) +import GHC.Cmm.Dataflow.Label (Label) +import GHC.Cmm.Info.Build (emptySRT) +import GHC.Cmm.Pipeline (cmmPipeline) +import GHC.Cmm.Utils (toBlockList) +import GHC.Data.Maybe (firstJusts) +import GHC.Data.Stream (Stream, liftIO) +import qualified GHC.Data.Stream as Stream +import GHC.Driver.Env (hsc_dflags) +import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) +import GHC.Driver.Session (gopt, targetPlatform) +import GHC.Plugins (HscEnv, NonCaffySet) +import GHC.Prelude +import GHC.Runtime.Heap.Layout (isStackRep) +import GHC.Settings (Platform, platformUnregisterised) +import GHC.StgToCmm.Monad (getCmm, initC, runC) +import GHC.StgToCmm.Prof (initInfoTableProv) +import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) +import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) +import GHC.Types.Tickish (GenTickish (SourceNote)) +import GHC.Unit.Types (Module) + +{- +Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Stacktraces can be created from return frames as they are pushed to stack for every case scrutinee. +But to make them readable / meaningful, one needs to know the source location of each return frame. + +Every return frame has a distinct info table and thus a distinct code pointer (for tables next to +code) or at least a distict address itself. Info Table Provernance Entries (IPE) are searchable by +this pointer and contain a source location. + +The info table / info table code pointer to source location map is described in: +Note [Mapping Info Tables to Source Positions] + +To be able to lookup IPEs for return frames one needs to emit them during compile time. This is done +by `generateCgIPEStub`. + +This leads to the question: How to figure out the source location of a return frame? + +While the lookup algorithms for registerised and unregisterised builds differ in details, they have in +common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest +(before) the usage of the return frame's label. (Which label and label type is used differs between +these two use cases.) + +Registerised +~~~~~~~~~~~~~ + +Let's consider this example: +``` + Main.returnFrame_entry() { // [R2] + { info_tbls: [(c18g, + label: block_c18g_info + rep: StackRep [] + srt: Just GHC.CString.unpackCString#_closure), + (c18r, + label: Main.returnFrame_info + rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + + [...] + + c18u: // global + //tick src<Main.hs:(7,1)-(16,15)> + I64[Hp - 16] = sat_s16B_info; + P64[Hp] = _s16r::P64; + _c17j::P64 = Hp - 16; + //tick src<Main.hs:8:25-39> + I64[Sp - 8] = c18g; + R3 = _c17j::P64; + R2 = GHC.IO.Unsafe.unsafePerformIO_closure; + R1 = GHC.Base.$_closure; + Sp = Sp - 8; + call stg_ap_pp_fast(R3, + R2, + R1) returns to c18g, args: 8, res: 8, upd: 8; +``` + +The return frame `block_c18g_info` has the label `c18g` which is used in the call to `stg_ap_pp_fast` +(`returns to c18g`) as continuation (`cml_cont`). The source location we're after, is the nearest +`//tick` before the call (`//tick src<Main.hs:8:25-39>`). + +In code the Cmm program is represented as a Hoopl graph. Hoopl distinguishes nodes by defining if they +are open or closed on entry (one can fallthrough to them from the previous instruction) and if they are +open or closed on exit (one can fallthrough from them to the next node). + +Please refer to the paper "Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation" +for a detailed explanation. + +Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit +(`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block. + +So, given a stack represented info table (likely representing a return frame, but this isn't completely +sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`: + - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the + label of the return frame. + - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block + backwards (from end to beginning). + - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as + `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are + ignored.) + +Unregisterised +~~~~~~~~~~~~~ + +In unregisterised builds there is no return frame / continuation label in calls. The continuation (i.e. return +frame) is set in an explicit Cmm assignment. Thus the tick lookup algorithm has to be slightly different. + +``` + sat_s16G_entry() { // [R1] + { info_tbls: [(c18O, + label: sat_s16G_info + rep: HeapRep { Thunk } + srt: Just _u18Z_srt)] + stack_info: arg_space: 0 + } + {offset + c18O: // global + _s16G::P64 = R1; + if ((Sp + 8) - 40 < SpLim) (likely: False) goto c18P; else goto c18Q; + c18P: // global + R1 = _s16G::P64; + call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8; + c18Q: // global + I64[Sp - 16] = stg_upd_frame_info; + P64[Sp - 8] = _s16G::P64; + //tick src<Main.hs:20:9-13> + I64[Sp - 24] = block_c18M_info; + R1 = GHC.Show.$fShow[]_closure; + P64[Sp - 32] = GHC.Show.$fShowChar_closure; + Sp = Sp - 32; + call stg_ap_p_fast(R1) args: 16, res: 8, upd: 24; + } + }, + _blk_c18M() { // [R1] + { info_tbls: [(c18M, + label: block_c18M_info + rep: StackRep [] + srt: Just System.IO.print_closure)] + stack_info: arg_space: 0 + } + {offset + c18M: // global + _s16F::P64 = R1; + R1 = System.IO.print_closure; + P64[Sp] = _s16F::P64; + call stg_ap_p_fast(R1) args: 32, res: 0, upd: 24; + } + }, +``` + +In this example we have to lookup `//tick src<Main.hs:20:9-13>` for the return frame `c18M`. +Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info` +(`label: block_c18M_info` is actually a `CLabel`). + +The find the tick: + - Every `Block` is checked from top (first) to bottom (last) node for an assignment like + `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored. + - If such an assignment is found the search is over, because the payload (content of + `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always + remembered in a `Maybe`. +-} + +generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos +generateCgIPEStub hsc_env this_mod denv s = do + let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + cgState <- liftIO initC + + -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty. + let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing + (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s + + -- Yield Cmm for Info Table Provenance Entries (IPEs) + let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)} + ((ipeStub, ipeCmmGroup), _) = runC dflags this_mod cgState $ getCmm (initInfoTableProv (map sndOfTriple labeledInfoTablesWithTickishes) denv' this_mod) + + (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup + Stream.yield ipeCmmGroupSRTs + + return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub} + where + collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs) + collect platform acc cmmGroupSRTs = do + let labelsToInfoTables = collectInfoTables cmmGroupSRTs + labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables + return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs) + + collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs) + collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs) + + sndOfTriple :: (a, b, c) -> b + sndOfTriple (_, b, _) = b + + collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)] + collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup + + extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)] + extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h) + extractInfoTables _ = Nothing + + lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation + lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do + -- All return frame info tables are stack represented, though not all stack represented info + -- tables have to be return frames. + if (isStackRep . cit_rep) infoTable + then do + let findFun = + if platformUnregisterised platform + then findCmmTickishForForUnregistered (cit_lbl infoTable) + else findCmmTickishForRegistered infoTableLabel + blocks = concatMap toBlockList (graphs cmmGroup) + firstJusts $ map findFun blocks + else Nothing + graphs :: CmmGroupSRTs -> [CmmGraph] + graphs = foldl' go [] + where + go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph] + go acc (CmmProc _ _ _ g) = g : acc + go acc _ = acc + + findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation + findCmmTickishForRegistered label block = do + let (_, middleBlock, endBlock) = blockSplit block + + isCallWithReturnFrameLabel endBlock label + lastTickInBlock middleBlock + where + isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe () + isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just () + isCallWithReturnFrameLabel _ _ = Nothing + + lastTickInBlock block = + listToMaybe $ + catMaybes $ + map maybeTick $ (reverse . blockToList) block + + maybeTick :: CmmNode O O -> Maybe IpeSourceLocation + maybeTick (CmmTick (SourceNote span name)) = Just (span, name) + maybeTick _ = Nothing + + findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation + findCmmTickishForForUnregistered cLabel block = do + let (_, middleBlock, _) = blockSplit block + find cLabel (blockToList middleBlock) Nothing + where + find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation + find label (b : blocks) lastTick = case b of + (CmmStore _ (CmmLit (CmmLabel l))) -> if label == l then lastTick else find label blocks lastTick + (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name) + _ -> find label blocks lastTick + find _ [] _ = Nothing diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index e4f4262d5e..ded0683ec0 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -49,7 +49,6 @@ import GHC.Types.CostCentre import GHC.Types.IPE import GHC.Types.Meta import GHC.Types.HpcInfo -import GHC.Types.ForeignStubs import GHC.Unit.Module import GHC.Unit.Module.ModSummary @@ -146,7 +145,7 @@ data Hooks = Hooks -> IO (Maybe HValue))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) , stgToCmmHook :: !(Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs - -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (CStub, ModuleLFInfos))) + -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)) , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a))) } diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index a01c559c80..3605b4ac5a 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fprof-auto-top #-} @@ -236,6 +237,9 @@ import Control.DeepSeq (force) import Data.Bifunctor (first) import GHC.Data.Maybe import GHC.Driver.Env.KnotVars +import GHC.Types.Name.Set (NonCaffySet) +import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) + {- ********************************************************************** %* * @@ -1756,7 +1760,7 @@ doCodeGen hsc_env this_mod denv data_tycons Nothing -> StgToCmm.codeGen logger tmpfs Just h -> h - let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos) + let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds] cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info @@ -1774,21 +1778,21 @@ doCodeGen hsc_env this_mod denv data_tycons ppr_stream1 = Stream.mapM dump1 cmm_stream - pipeline_stream :: Stream IO CmmGroupSRTs CgInfos + pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) pipeline_stream = do - (non_cafs, (used_info, lf_infos)) <- + (non_cafs, lf_infos) <- {-# SCC "cmmPipeline" #-} Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 <&> first (srtMapNonCAFs . moduleSRTMap) - return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos, cgIPEStub = used_info } + return (non_cafs, lf_infos) dump2 a = do unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a - return (Stream.mapM dump2 pipeline_stream) + return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext -> Bool diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index 1195f83937..3e6f6ed405 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -174,6 +174,7 @@ data SMRep | RTSRep -- The RTS needs to declare info tables with specific Int -- type tags, so this form lets us override the default SMRep -- tag for an SMRep. + deriving Eq -- | True \<=> This is a static closure. Affects how we garbage-collect it. -- Static closure have an extra static link field at the end. @@ -191,6 +192,7 @@ data ClosureTypeInfo | ThunkSelector SelectorOffset | BlackHole | IndStatic + deriving Eq type ConstrDescription = ByteString -- result of dataConIdentity type FunArity = Int @@ -445,6 +447,8 @@ rtsClosureType rep HeapRep False _ _ BlackHole -> BLACKHOLE HeapRep False _ _ IndStatic -> IND_STATIC + StackRep _ -> STACK + _ -> panic "rtsClosureType" -- We export these ones diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs index 77ef7910ec..bea6fe5c8e 100644 --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -33,7 +33,7 @@ data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe type M a = ReaderT R (State InfoTableProvMap) a -withSpan :: (RealSrcSpan, String) -> M a -> M a +withSpan :: IpeSourceLocation -> M a -> M a withSpan (new_s, new_l) act = local maybe_replace act where maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) } @@ -171,16 +171,21 @@ to a position in the source. The prime example is being able to map a THUNK to a specific place in the source program, the mapping is usually quite precise because a fresh info table is created for each distinct THUNK. +The info table map is also used to generate stacktraces. +See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +for details. + There are three parts to the implementation -1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location to -some specific closures. -2. In StgToCmm, the actually used info tables are recorded in an IORef, this -is important as it's hard to predict beforehand what code generation will do -and which ids will end up in the generated program. -3. During code generation, a mapping from the info table to the statically -determined location is emitted which can then be queried at runtime by -various tools. +1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location + to some specific closures. +2. In GHC.Driver.GenerateCgIPEStub, the actually used info tables are collected after the + Cmm pipeline. This is important as it's hard to predict beforehand what code generation + will do and which ids will end up in the generated program. Additionally, info tables of + return frames (used to create stacktraces) are generated in the Cmm pipeline and aren't + available before. +3. During code generation, a mapping from the info table to the statically determined location + is emitted which can then be queried at runtime by various tools. -- Giving Source Locations to Closures @@ -189,6 +194,8 @@ is collected in the `InfoTableProvMap` which provides a mapping from: 1. Data constructors to a list of where they are used. 2. `Name`s and where they originate from. +3. Stack represented info tables (return frames) to an approximated source location + of the call that pushed a contiunation on the stacks. During the CoreToStg phase, this map is populated whenever something is turned into a StgRhsClosure or an StgConApp. The current source position is recorded @@ -197,28 +204,27 @@ depending on the location indicated by the surrounding SourceNote. The functions which add information to the map are `recordStgIdPosition` and `numberDataCon`. -When the -fdistinct-constructor-tables` flag is turned on then every +When the `-fdistinct-constructor-tables` flag is turned on then every usage of a data constructor gets its own distinct info table. This is orchestrated in `collectExpr` where an incrementing number is used to distinguish each occurrence of a data constructor. --- StgToCmm +-- GenerateCgIPEStub + +The info tables which are actually used in the generated program are collected after +the Cmm pipeline. `initInfoTableProv` is used to create a CStub, that initializes the +map in C code. -The info tables which are actually used in the generated program are recorded during the -conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function. -All the used info tables are recorded in the `cgs_used_info` field. This step -is necessary because when the information about names is collected in the previous -phase it's unpredictable about which names will end up needing info tables. If -you don't record which ones are actually used then you end up generating code -which references info tables which don't exist. +This step has to be done after the Cmm pipeline to make sure that all info tables are +really used and, even more importantly, return frame info tables are generated by the +pipeline. -- Code Generation The output of these two phases is combined together during code generation. -A C stub is generated which -creates the static map from info table pointer to the information about where that -info table was created from. This is created by `ipInitCode` in the same manner as a -C stub is generated for cost centres. +A C stub is generated which creates the static map from info table pointer to the +information about where that info table was created from. This is created by +`ipInitCode` in the same manner as a C stub is generated for cost centres. This information can be consumed in two ways. diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 546c270f76..ee297e4220 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -18,7 +18,7 @@ import GHC.Prelude as Prelude import GHC.Driver.Backend import GHC.Driver.Session -import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter) +import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env import GHC.StgToCmm.Bind @@ -47,7 +47,6 @@ import GHC.Types.Basic import GHC.Types.Var.Set ( isEmptyDVarSet ) import GHC.Types.Unique.FM import GHC.Types.Name.Env -import GHC.Types.ForeignStubs import GHC.Core.DataCon import GHC.Core.TyCon @@ -70,13 +69,8 @@ import Control.Monad (when,void, forM_) import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS -import Data.Maybe import Data.IORef -data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable) - , codegen_state :: !CgState } - - codeGen :: Logger -> TmpFs -> DynFlags @@ -86,34 +80,26 @@ codeGen :: Logger -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [CgStgTopBinding] -- Bindings to convert -> HpcInfo - -> Stream IO CmmGroup (CStub, ModuleLFInfos) -- Output as a stream, so codegen can + -> Stream IO CmmGroup ModuleLFInfos -- Output as a stream, so codegen can -- be interleaved with output -codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons +codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_tycons cost_centre_info stg_binds hpc_info = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise -- we would need to add a state monad layer which regresses -- allocations by 0.5-2%. - ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s) + ; cgref <- liftIO $ initC >>= \s -> newIORef s ; let cg :: FCode a -> Stream IO CmmGroup a cg fcode = do (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do - CodeGenState ts st <- readIORef cgref + st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode) -- NB. stub-out cgs_tops and cgs_stmts. This fixes -- a big space leak. DO NOT REMOVE! -- This is observed by the #3294 test - let !used_info - | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts - | otherwise = mempty - writeIORef cgref $! - CodeGenState used_info - (st'{ cgs_tops = nilOL, - cgs_stmts = mkNop - }) - + writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop }) return a yield cmm return a @@ -144,10 +130,7 @@ codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv) ; final_state <- liftIO (readIORef cgref) - ; let cg_id_infos = cgs_binds . codegen_state $ final_state - used_info = fromOL . codegen_used_info $ final_state - - ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod) + ; let cg_id_infos = cgs_binds final_state -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types @@ -162,7 +145,7 @@ codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) | otherwise = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos)) - ; return (foreign_stub, generatedInfo) + ; return generatedInfo } --------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 0f5943bf48..dff86341b1 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1669,7 +1669,6 @@ emitPrimOp dflags primop = case primop of TraceEventBinaryOp -> alwaysExternal TraceMarkerOp -> alwaysExternal SetThreadAllocationCounter -> alwaysExternal - CloneMyStack -> alwaysExternal -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep. KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep" diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 58fdfeafd9..852b77ef2b 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -284,8 +284,6 @@ initInfoTableProv infos itmap this_mod = do dflags <- getDynFlags let ents = convertInfoProvMap dflags infos this_mod itmap - --pprTraceM "UsedInfo" (ppr (length infos)) - --pprTraceM "initInfoTable" (ppr (length ents)) -- Output the actual IPE data mapM_ emitInfoTableProv ents -- Create the C stub which initialises the IPE map diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 934fd6d726..8c6a40c69d 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -90,6 +90,7 @@ import GHC.Core.DataCon import GHC.Types.Unique.FM import GHC.Data.Maybe import Control.Monad +import qualified Data.Map.Strict as Map -------------------------------------------------------------------------- -- @@ -600,7 +601,7 @@ cmmInfoTableToInfoProvEnt this_mod cmit = -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenenance table. convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] -convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) = +convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) = map (\cmit -> let cl = cit_lbl cmit cn = rtsClosureType (cit_rep cmit) @@ -620,8 +621,16 @@ convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) -- Lookup is linear but lists will be small (< 100) return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)) + lookupInfoTableToSourceLocation = do + sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap + return $ InfoProvEnt cl cn "" this_mod sourceNote + -- This catches things like prim closure types and anything else which doesn't have a -- source location simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit - in fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns + in + if (isStackRep . cit_rep) cmit then + fromMaybe simpleFallback lookupInfoTableToSourceLocation + else + fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns diff --git a/compiler/GHC/Types/IPE.hs b/compiler/GHC/Types/IPE.hs index c69aeb004a..461bae6a55 100644 --- a/compiler/GHC/Types/IPE.hs +++ b/compiler/GHC/Types/IPE.hs @@ -1,5 +1,10 @@ -module GHC.Types.IPE(DCMap, ClosureMap, InfoTableProvMap(..) - , emptyInfoTableProvMap) where +module GHC.Types.IPE ( + DCMap, + ClosureMap, + InfoTableProvMap(..), + emptyInfoTableProvMap, + IpeSourceLocation +) where import GHC.Prelude @@ -10,11 +15,17 @@ import GHC.Core.DataCon import GHC.Types.Unique.Map import GHC.Core.Type import Data.List.NonEmpty +import GHC.Cmm.CLabel (CLabel) +import qualified Data.Map.Strict as Map + +-- | Position and information about an info table. +-- For return frames these are the contents of a 'CoreSyn.SourceNote'. +type IpeSourceLocation = (RealSrcSpan, String) -- | A map from a 'Name' to the best approximate source position that -- name arose from. type ClosureMap = UniqMap Name -- The binding - (Type, Maybe (RealSrcSpan, String)) + (Type, Maybe IpeSourceLocation) -- The best approximate source position. -- (rendered type, source position, source note -- label) @@ -26,11 +37,15 @@ type ClosureMap = UniqMap Name -- The binding -- the constructor was used at, if possible and a string which names -- the source location. This is the same information as is the payload -- for the 'GHC.Core.SourceNote' constructor. -type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe (RealSrcSpan, String))) +type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation)) + +type InfoTableToSourceLocationMap = Map.Map CLabel (Maybe IpeSourceLocation) data InfoTableProvMap = InfoTableProvMap { provDC :: DCMap - , provClosure :: ClosureMap } + , provClosure :: ClosureMap + , provInfoTables :: InfoTableToSourceLocationMap + } emptyInfoTableProvMap :: InfoTableProvMap -emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap +emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap Map.empty diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index b1acf005da..25833017d1 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -426,6 +426,7 @@ Library GHC.Driver.Errors.Ppr GHC.Driver.Errors.Types GHC.Driver.Flags + GHC.Driver.GenerateCgIPEStub GHC.Driver.Hooks GHC.Driver.Main GHC.Driver.Make diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc index 67e50ae9a1..a8af10a1a1 100644 --- a/libraries/base/GHC/Stack/CCS.hsc +++ b/libraries/base/GHC/Stack/CCS.hsc @@ -34,7 +34,11 @@ module GHC.Stack.CCS ( ccModule, ccSrcSpan, ccsToStrings, - renderStack + renderStack, + ipeProv, + peekInfoProv, + InfoProv(..), + InfoProvEnt, ) where import Foreign @@ -45,6 +49,7 @@ import GHC.Ptr import GHC.Foreign as GHC import GHC.IO.Encoding import GHC.List ( concatMap, reverse ) +import GHC.Show (Show) #define PROFILING #include "Rts.h" @@ -139,7 +144,14 @@ renderStack strs = -- Static Closure Information -data InfoProv +data InfoProv = InfoProv { + ipName :: String, + ipDesc :: String, + ipTyDesc :: String, + ipLabel :: String, + ipMod :: String, + ipLoc :: String +} deriving (Eq, Show) data InfoProvEnt getIPE :: a -> IO (Ptr InfoProvEnt) @@ -150,25 +162,31 @@ getIPE obj = IO $ \s -> ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv ipeProv p = (#ptr InfoProvEnt, prov) p -ipName, ipDesc, ipLabel, ipModule, ipSrcLoc, ipTyDesc :: Ptr InfoProv -> IO CString -ipName p = (# peek InfoProv, table_name) p -ipDesc p = (# peek InfoProv, closure_desc) p -ipLabel p = (# peek InfoProv, label) p -ipModule p = (# peek InfoProv, module) p -ipSrcLoc p = (# peek InfoProv, srcloc) p -ipTyDesc p = (# peek InfoProv, ty_desc) p - -infoProvToStrings :: Ptr InfoProv -> IO [String] -infoProvToStrings infop = do - name <- GHC.peekCString utf8 =<< ipName infop - desc <- GHC.peekCString utf8 =<< ipDesc infop - ty_desc <- GHC.peekCString utf8 =<< ipTyDesc infop - label <- GHC.peekCString utf8 =<< ipLabel infop - mod <- GHC.peekCString utf8 =<< ipModule infop - loc <- GHC.peekCString utf8 =<< ipSrcLoc infop - return [name, desc, ty_desc, label, mod, loc] - --- TODO: Add structured output of whereFrom +peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcLoc, peekIpTyDesc :: Ptr InfoProv -> IO CString +peekIpName p = (# peek InfoProv, table_name) p +peekIpDesc p = (# peek InfoProv, closure_desc) p +peekIpLabel p = (# peek InfoProv, label) p +peekIpModule p = (# peek InfoProv, module) p +peekIpSrcLoc p = (# peek InfoProv, srcloc) p +peekIpTyDesc p = (# peek InfoProv, ty_desc) p + +peekInfoProv :: Ptr InfoProv -> IO InfoProv +peekInfoProv infop = do + name <- GHC.peekCString utf8 =<< peekIpName infop + desc <- GHC.peekCString utf8 =<< peekIpDesc infop + tyDesc <- GHC.peekCString utf8 =<< peekIpTyDesc infop + label <- GHC.peekCString utf8 =<< peekIpLabel infop + mod <- GHC.peekCString utf8 =<< peekIpModule infop + loc <- GHC.peekCString utf8 =<< peekIpSrcLoc infop + return InfoProv { + ipName = name, + ipDesc = desc, + ipTyDesc = tyDesc, + ipLabel = label, + ipMod = mod, + ipLoc = loc + } + -- | Get information about where a value originated from. -- This information is stored statically in a binary when `-finfo-table-map` is -- enabled. The source positions will be greatly improved by also enabled debug @@ -178,7 +196,7 @@ infoProvToStrings infop = do -- The information is collect by looking at the info table address of a specific closure and -- then consulting a specially generated map (by `-finfo-table-map`) to find out where we think -- the best source position to describe that info table arose from. -whereFrom :: a -> IO [String] +whereFrom :: a -> IO (Maybe InfoProv) whereFrom obj = do ipe <- getIPE obj -- The primop returns the null pointer in two situations at the moment @@ -186,5 +204,7 @@ whereFrom obj = do -- 2. -finfo-table-map is not enabled. -- It would be good to distinguish between these two cases somehow. if ipe == nullPtr - then return [] - else infoProvToStrings (ipeProv ipe) + then return Nothing + else do + infoProv <- peekInfoProv (ipeProv ipe) + return $ Just infoProv diff --git a/libraries/base/GHC/Stack/CloneStack.hs b/libraries/base/GHC/Stack/CloneStack.hs index 68077d4299..f06ecad070 100644 --- a/libraries/base/GHC/Stack/CloneStack.hs +++ b/libraries/base/GHC/Stack/CloneStack.hs @@ -1,31 +1,47 @@ {-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes#-} +{-# LANGUAGE GHCForeignImportPrim #-} -- | -- This module exposes an interface for capturing the state of a thread's --- execution stack for diagnostics purposes. +-- execution stack for diagnostics purposes: 'cloneMyStack', +-- 'cloneThreadStack'. +-- +-- Such a "cloned" stack can be decoded with 'decode' to a stack trace, given +-- that the @-finfo-table-map@ is enabled. -- -- @since 2.16.0.0 module GHC.Stack.CloneStack ( StackSnapshot(..), + StackEntry(..), cloneMyStack, - cloneThreadStack + cloneThreadStack, + decode ) where -import GHC.Prim (StackSnapshot#, cloneMyStack#, ThreadId#) import Control.Concurrent.MVar +import Data.Maybe (catMaybes) +import Foreign import GHC.Conc.Sync +import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#) +import GHC.IO (IO (..)) +import GHC.Stack.CCS (InfoProv (..), InfoProvEnt, ipeProv, peekInfoProv) import GHC.Stable -import GHC.IO (IO(..)) -- | A frozen snapshot of the state of an execution stack. -- -- @since 2.16.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# +foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #) + +foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) + +foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #) + {- Note [Stack Cloning] ~~~~~~~~~~~~~~~~~~~~ @@ -55,8 +71,9 @@ or `StablePtr`: - `StablePtr` has to be freed explictly, which would introduce nasty state handling. -By using a primitive type, the stack closure is kept and managed by the garbage -collector as long as it's in use and automatically freed later. +By using a primitive type, the stack closure (and its transitive closures) is +kept and managed by the garbage collector as long as it's in use and +automatically freed later. As closures referred to by stack closures (e.g. payloads) may be used by other closures that are not related to stack cloning, the memory has to be managed by the garbage collector; i.e. one cannot simply call free() in the RTS C code @@ -67,7 +84,7 @@ RTS interface ------------- There are two different ways to clone a stack: 1. `cloneMyStack#` - A primop for cloning the active thread's stack. -2. `sendCloneStackMessage` - A FFI function for cloning another thread's stack. +2. `sendCloneStackMessage#` - A primop for cloning another thread's stack. Sends a RTS message (Messages.c) with a MVar to that thread. The cloned stack is reveived by taking it out of this MVar. @@ -130,6 +147,39 @@ function that dispatches messages is `executeMessage`. From there (`msg->mvar`). -} +{- +Note [Stack Decoding] +~~~~~~~~~~~~~~~~~~~~~ +A cloned stack is decoded (unwound) by looking up the Info Table Provenance +Entries (IPE) for every stack frame with `lookupIPE` in the RTS. + +The IPEs contain source locations and are pulled from the RTS/C world into +Haskell. + +RTS interface +------------- + +The primop decodeStack# returns an array of IPE pointers that are later +unmarshalled with HSC. If there is no IPE for a return frame (which can easily +happen when a library wasn't compiled with `-finfo-table-map`), it's +represented by a null pointer. + +Caveats: +- decodeStack# has to be a primop (not a simple C FFI function), because + there always has to be at least one active `TSO`. Otherwise, allocating + memory with the garbage collector for the returned value fails. +- decodeStack# has to be defined outside of `primops.txt.pp` because its + return type `Array# (Ptr InfoProvEnt)` cannot be defined there: + `InfoProvEnt` and `Ptr` would have to be imported which seems to be too + specific for this file. + +Notes +----- +The relevant notes are: + - Note [Mapping Info Tables to Source Positions] + - Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +-} + -- | Clone the stack of the executing thread -- -- @since 2.16.0.0 @@ -137,18 +187,78 @@ cloneMyStack :: IO StackSnapshot cloneMyStack = IO $ \s -> case (cloneMyStack# s) of (# s1, stack #) -> (# s1, StackSnapshot stack #) -foreign import ccall "sendCloneStackMessage" sendCloneStackMessage :: ThreadId# -> StablePtr PrimMVar -> IO () - -- | Clone the stack of a thread identified by its 'ThreadId' -- -- @since 2.16.0.0 cloneThreadStack :: ThreadId -> IO StackSnapshot cloneThreadStack (ThreadId tid#) = do resultVar <- newEmptyMVar @StackSnapshot - ptr <- newStablePtrPrimMVar resultVar + boxedPtr@(StablePtr ptr) <- newStablePtrPrimMVar resultVar -- Use the RTS's "message" mechanism to request that -- the thread captures its stack, saving the result -- into resultVar. - sendCloneStackMessage tid# ptr - freeStablePtr ptr + IO $ \s -> case sendCloneStackMessage# tid# ptr s of (# s', (# #) #) -> (# s', () #) + freeStablePtr boxedPtr takeMVar resultVar + +-- | Represetation for the source location where a return frame was pushed on the stack. +-- This happens every time when a @case ... of@ scrutinee is evaluated. +data StackEntry = StackEntry + { functionName :: String, + moduleName :: String, + srcLoc :: String, + closureType :: Word + } + deriving (Show, Eq) + +-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). +-- The stack trace is created from return frames with according 'InfoProvEnt' +-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are +-- no 'InfoProvEnt' entries, an empty list is returned. +-- +-- Please note: +-- +-- * To gather 'StackEntry' from libraries, these have to be +-- compiled with @-finfo-table-map@, too. +-- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change +-- with different GHC parameters and versions. +-- * The stack trace is empty (by design) if there are no return frames on +-- the stack. (These are pushed every time when a @case ... of@ scrutinee +-- is evaluated.) +-- +-- @since 2.16.0.0 +decode :: StackSnapshot -> IO [StackEntry] +decode stackSnapshot = do + stackEntries <- getDecodedStackArray stackSnapshot + ipes <- mapM unmarshall stackEntries + return $ catMaybes ipes + + where + unmarshall :: Ptr InfoProvEnt -> IO (Maybe StackEntry) + unmarshall ipe = if ipe == nullPtr then + pure Nothing + else do + infoProv <- (peekInfoProv . ipeProv) ipe + pure $ Just (toStackEntry infoProv) + toStackEntry :: InfoProv -> StackEntry + toStackEntry infoProv = + StackEntry + { functionName = ipLabel infoProv, + moduleName = ipMod infoProv, + srcLoc = ipLoc infoProv, + -- read looks dangerous, be we can trust that the closure type is always there. + closureType = read . ipDesc $ infoProv + } + +getDecodedStackArray :: StackSnapshot -> IO [Ptr InfoProvEnt] +getDecodedStackArray (StackSnapshot s) = + IO $ \s0 -> case decodeStack# s s0 of + (# s1, a #) -> (# s1, (go a ((I# (sizeofArray# a)) - 1)) #) + where + go :: Array# (Ptr InfoProvEnt) -> Int -> [Ptr InfoProvEnt] + go stack 0 = [stackEntryAt stack 0] + go stack i = (stackEntryAt stack i) : go stack (i - 1) + + stackEntryAt :: Array# (Ptr InfoProvEnt) -> Int -> Ptr InfoProvEnt + stackEntryAt stack (I# i) = case indexArray# stack i of + (# se #) -> se diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 90ab51c214..0f7023ae79 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -352,6 +352,7 @@ Library cmm-sources: cbits/CastFloatWord.cmm + cbits/StackCloningDecoding.cmm include-dirs: include includes: diff --git a/libraries/base/cbits/StackCloningDecoding.cmm b/libraries/base/cbits/StackCloningDecoding.cmm new file mode 100644 index 0000000000..17b71dd0f0 --- /dev/null +++ b/libraries/base/cbits/StackCloningDecoding.cmm @@ -0,0 +1,26 @@ +#include "Cmm.h" + +stg_cloneMyStackzh () { + gcptr stgStack; + gcptr clonedStack; + + stgStack = StgTSO_stackobj(CurrentTSO); + StgStack_sp(stgStack) = Sp; + + ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr"); + + return (clonedStack); +} + +stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) { + ccall sendCloneStackMessage(threadId "ptr", mVarStablePtr "ptr"); + + return (); +} + +stg_decodeStackzh (gcptr stgStack) { + gcptr stackEntries; + ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr"); + + return (stackEntries); +} diff --git a/rts/CloneStack.c b/rts/CloneStack.c index a8e826eec1..d9f5fd8725 100644 --- a/rts/CloneStack.c +++ b/rts/CloneStack.c @@ -1,23 +1,27 @@ /* --------------------------------------------------------------------------- * - * (c) The GHC Team, 2001-2021 + * (c) The GHC Team, 2020-2021 * - * Stack snapshotting. - */ + * Stack snapshotting and decoding. (Cloning and unwinding.) + * + *---------------------------------------------------------------------------*/ #include <string.h> #include "Rts.h" #include "rts/Messages.h" #include "Messages.h" +#include "rts/Types.h" #include "rts/storage/TSO.h" #include "stg/Types.h" #include "CloneStack.h" #include "StablePtr.h" #include "Threads.h" +#include "Prelude.h" #if defined(DEBUG) #include "sm/Sanity.h" +#include "Printer.h" #endif static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack) @@ -47,9 +51,8 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack) StgStack *last_stack = top_stack; while (true) { // check whether the stack ends in an underflow frame - StgPtr top = last_stack->stack + last_stack->stack_size; - StgUnderflowFrame *underFlowFrame = ((StgUnderflowFrame *) top); - StgUnderflowFrame *frame = underFlowFrame--; + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); if (frame->info == &stg_stack_underflow_frame_info) { StgStack *s = cloneStackChunk(capability, frame->next_chunk); frame->next_chunk = s; @@ -101,3 +104,115 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) } #endif // end !defined(THREADED_RTS) + +// Creates a MutableArray# (Haskell representation) that contains a +// InfoProvEnt* for every stack frame on the given stack. Thus, the size of the +// array is the count of stack frames. +// Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack +// frame it's represented by null. +StgMutArrPtrs* decodeClonedStack(Capability *cap, StgStack* stack) { + StgWord closureCount = getStackFrameCount(stack); + + StgMutArrPtrs* array = allocateMutableArray(closureCount); + + copyPtrsToArray(cap, array, stack); + + return array; +} + +// Count the stack frames that are on the given stack. +// This is the sum of all stack frames in all stack chunks of this stack. +StgWord getStackFrameCount(StgStack* stack) { + StgWord closureCount = 0; + StgStack *last_stack = stack; + while (true) { + closureCount += getStackChunkClosureCount(last_stack); + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } + return closureCount; +} + +StgWord getStackChunkClosureCount(StgStack* stack) { + StgWord closureCount = 0; + StgPtr sp = stack->sp; + StgPtr spBottom = stack->stack + stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + closureCount++; + } + + return closureCount; +} + +// Allocate and initialize memory for a MutableArray# (Haskell representation). +StgMutArrPtrs* allocateMutableArray(StgWord closureCount) { + // Idea stolen from PrimOps.cmm:stg_newArrayzh() + StgWord size = closureCount + mutArrPtrsCardTableSize(closureCount); + StgWord words = sizeofW(StgMutArrPtrs) + size; + + StgMutArrPtrs* array = (StgMutArrPtrs*) allocate(myTask()->cap, words); + + SET_HDR(array, &stg_MUT_ARR_PTRS_DIRTY_info, CCS_SYSTEM); + array->ptrs = closureCount; + array->size = size; + + return array; +} + + +void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack) { + StgWord index = 0; + StgStack *last_stack = stack; + while (true) { + StgPtr sp = last_stack->sp; + StgPtr spBottom = last_stack->stack + last_stack->stack_size; + for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { + const StgInfoTable* infoTable = get_itbl((StgClosure *)sp); + + // Add the IPE that was looked up by lookupIPE() to the MutableArray#. + // The "Info Table Provernance Entry Map" (IPE) idea is to use a pointer + // (address) to the info table to lookup entries, this is fulfilled in + // non-"Tables Next to Code" builds. + // When "Tables Next to Code" is used, the assembly label of the info table + // is between the info table and it's code. There's no other label in the + // assembly code which could be used instead, thus lookupIPE() is actually + // called with the code pointer of the info table. + // (As long as it's used consistently, this doesn't really matter - IPE uses + // the pointer only to connect an info table to it's provenance entry in the + // IPE map.) +#if defined(TABLES_NEXT_TO_CODE) + InfoProvEnt* ipe = lookupIPE((StgInfoTable*) infoTable->code); +#else + InfoProvEnt* ipe = lookupIPE(infoTable); +#endif + arr->payload[index] = createPtrClosure(cap, ipe); + + index++; + } + + // check whether the stack ends in an underflow frame + StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack + + last_stack->stack_size - sizeofW(StgUnderflowFrame)); + if (frame->info == &stg_stack_underflow_frame_info) { + last_stack = frame->next_chunk; + } else { + break; + } + } +} + +// Create a GHC.Ptr (Haskell constructor: `Ptr InfoProvEnt`) pointing to the +// IPE. +StgClosure* createPtrClosure(Capability *cap, InfoProvEnt* ipe) { + StgClosure *p = (StgClosure *) allocate(cap, CONSTR_sizeW(0,1)); + SET_HDR(p, &base_GHCziPtr_Ptr_con_info, CCS_SYSTEM); + p->payload[0] = (StgClosure*) ipe; + return TAG_CLOSURE(1, p); +} diff --git a/rts/CloneStack.h b/rts/CloneStack.h index 5f1c22039d..7e43d090d1 100644 --- a/rts/CloneStack.h +++ b/rts/CloneStack.h @@ -1,9 +1,10 @@ /* --------------------------------------------------------------------------- * - * (c) The GHC Team, 2001-2021 + * (c) The GHC Team, 2020-2021 * - * Stack snapshotting. - */ + * Stack snapshotting and decoding. (Cloning and unwinding.) + * + *---------------------------------------------------------------------------*/ #pragma once @@ -14,10 +15,18 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack); void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar); +StgMutArrPtrs* decodeClonedStack(Capability *cap, StgStack* stack); + #include "BeginPrivate.h" #if defined(THREADED_RTS) void handleCloneStackMessage(MessageCloneStack *msg); #endif +StgWord getStackFrameCount(StgStack* stack); +StgWord getStackChunkClosureCount(StgStack* stack); +void copyPtrsToArray(Capability *cap, StgMutArrPtrs* arr, StgStack* stack); +StgClosure* createPtrClosure(Capability* cap, InfoProvEnt* ipe); +StgMutArrPtrs* allocateMutableArray(StgWord size); + #include "EndPrivate.h" diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 122bac4e08..8f99105b18 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -2927,14 +2927,3 @@ stg_setThreadAllocationCounterzh ( I64 counter ) StgTSO_alloc_limit(CurrentTSO) = counter + TO_I64(offset); return (); } - -stg_cloneMyStackzh () { - W_ stgStack; - W_ clonedStack; - stgStack = StgTSO_stackobj(CurrentTSO); - StgStack_sp(stgStack) = Sp; - - ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr"); - - return (clonedStack); -} diff --git a/rts/Printer.c b/rts/Printer.c index d2a5c67ca4..ef9394f24e 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -678,7 +678,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) } } -static void printStack( StgStack *stack ) +void printStack( StgStack *stack ) { printStackChunk( stack->sp, stack->stack + stack->stack_size ); } diff --git a/rts/Printer.h b/rts/Printer.h index 44c55de3d6..959b5f0256 100644 --- a/rts/Printer.h +++ b/rts/Printer.h @@ -22,6 +22,7 @@ const char * info_update_frame ( const StgClosure *closure ); #if defined(DEBUG) extern void printClosure ( const StgClosure *obj ); +extern void printStack ( StgStack *stack ); extern void printStackChunk ( StgPtr sp, StgPtr spLim ); extern void printTSO ( StgTSO *tso ); extern void printMutableList( bdescr *bd ); diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index 56d94ee7d2..2782d3632f 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -989,7 +989,6 @@ SymI_HasProto(stg_traceBinaryEventzh) \ SymI_HasProto(stg_getThreadAllocationCounterzh) \ SymI_HasProto(stg_setThreadAllocationCounterzh) \ - SymI_HasProto(stg_cloneMyStackzh) \ SymI_HasProto(getMonotonicNSec) \ SymI_HasProto(lockFile) \ SymI_HasProto(unlockFile) \ @@ -1015,6 +1014,8 @@ SymI_HasProto(registerInfoProvList) \ SymI_HasProto(lookupIPE) \ SymI_HasProto(sendCloneStackMessage) \ + SymI_HasProto(cloneStack) \ + SymI_HasProto(decodeClonedStack) \ RTS_USER_SIGNALS_SYMBOLS \ RTS_INTCHAR_SYMBOLS diff --git a/rts/include/stg/MiscClosures.h b/rts/include/stg/MiscClosures.h index 1eed441eae..8c6b863d0a 100644 --- a/rts/include/stg/MiscClosures.h +++ b/rts/include/stg/MiscClosures.h @@ -571,8 +571,6 @@ RTS_FUN_DECL(stg_traceBinaryEventzh); RTS_FUN_DECL(stg_traceMarkerzh); RTS_FUN_DECL(stg_getThreadAllocationCounterzh); RTS_FUN_DECL(stg_setThreadAllocationCounterzh); -RTS_FUN_DECL(stg_cloneMyStackzh); - /* Other misc stuff */ // See wiki:commentary/compiler/backends/ppr-c#prototypes diff --git a/testsuite/tests/profiling/should_run/T7275.stdout b/testsuite/tests/profiling/should_run/T7275.stdout index d0146366a7..4dbeabc5c6 100644 --- a/testsuite/tests/profiling/should_run/T7275.stdout +++ b/testsuite/tests/profiling/should_run/T7275.stdout @@ -3,19 +3,19 @@ 2 3 4 -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert -(284)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert +(286)suzanne/robert diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T index b793bce24f..399ec3da71 100644 --- a/testsuite/tests/profiling/should_run/all.T +++ b/testsuite/tests/profiling/should_run/all.T @@ -14,13 +14,19 @@ test('dynamic-prof2', [only_ways(['normal']), extra_run_opts('+RTS -hT --no-auto test('dynamic-prof3', [only_ways(['normal']), extra_run_opts('+RTS -hT --no-automatic-heap-samples')], compile_and_run, ['']) +# Remove the ipName field as it's volatile (depends on e.g. architecture and may change with every new GHC version) +def normalise_InfoProv_ipName(str): + return re.sub('ipName = "\\w*"', '', str) + test('staticcallstack001', [ omit_ways(['ghci-ext-prof']), # produces a different stack + normalise_fun(normalise_InfoProv_ipName) ], compile_and_run, ['-O0 -g3 -fdistinct-constructor-tables -finfo-table-map']) test('staticcallstack002', [ omit_ways(['ghci-ext-prof']), # produces a different stack + normalise_fun(normalise_InfoProv_ipName) ], compile_and_run, ['-O0 -g3 -fdistinct-constructor-tables -finfo-table-map']) diff --git a/testsuite/tests/profiling/should_run/staticcallstack001.hs b/testsuite/tests/profiling/should_run/staticcallstack001.hs index 78849d0ef1..e3e1407492 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack001.hs +++ b/testsuite/tests/profiling/should_run/staticcallstack001.hs @@ -13,7 +13,6 @@ qq x = D x caf = D 5 main = do - print . tail =<< whereFrom (D 5) - print . tail =<< whereFrom caf - print . tail =<< whereFrom (id (D 5)) - + print =<< whereFrom (D 5) + print =<< whereFrom caf + print =<< whereFrom (id (D 5)) diff --git a/testsuite/tests/profiling/should_run/staticcallstack001.stdout b/testsuite/tests/profiling/should_run/staticcallstack001.stdout index 7da74c81d9..6a701358e3 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack001.stdout +++ b/testsuite/tests/profiling/should_run/staticcallstack001.stdout @@ -1,3 +1,3 @@ -["2","D","main","Main","staticcallstack001.hs:16:20-34"] -["2","D","caf","Main","staticcallstack001.hs:13:1-9"] -["15","D","main","Main","staticcallstack001.hs:18:30-39"] +Just (InfoProv {ipName = "D_Main_4_con_info", ipDesc = "2", ipTyDesc = "D", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack001.hs:16:13-27"}) +Just (InfoProv {ipName = "D_Main_2_con_info", ipDesc = "2", ipTyDesc = "D", ipLabel = "caf", ipMod = "Main", ipLoc = "staticcallstack001.hs:13:1-9"}) +Just (InfoProv {ipName = "sat_s11g_info", ipDesc = "15", ipTyDesc = "D", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack001.hs:18:23-32"}) diff --git a/testsuite/tests/profiling/should_run/staticcallstack002.hs b/testsuite/tests/profiling/should_run/staticcallstack002.hs index 87df13bee0..da3d66efb2 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack002.hs +++ b/testsuite/tests/profiling/should_run/staticcallstack002.hs @@ -7,8 +7,7 @@ import GHC.Stack.CCS -- a special case to not generate distinct info tables for unboxed -- constructors. main = do - print . tail =<< whereFrom (undefined (# #)) - print . tail =<< whereFrom (undefined (# () #)) - print . tail =<< whereFrom (undefined (# (), () #)) - print . tail =<< whereFrom (undefined (# | () #)) - + print =<< whereFrom (undefined (# #)) + print =<< whereFrom (undefined (# () #)) + print =<< whereFrom (undefined (# (), () #)) + print =<< whereFrom (undefined (# | () #)) diff --git a/testsuite/tests/profiling/should_run/staticcallstack002.stdout b/testsuite/tests/profiling/should_run/staticcallstack002.stdout index c96b6fa7f3..d3b62d47d2 100644 --- a/testsuite/tests/profiling/should_run/staticcallstack002.stdout +++ b/testsuite/tests/profiling/should_run/staticcallstack002.stdout @@ -1,4 +1,4 @@ -["15","Any","main","Main","staticcallstack002.hs:10:30-46"] -["15","Any","main","Main","staticcallstack002.hs:11:30-49"] -["15","Any","main","Main","staticcallstack002.hs:12:30-53"] -["15","Any","main","Main","staticcallstack002.hs:13:30-51"] +Just (InfoProv {ipName = "sat_s10U_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:10:23-39"}) +Just (InfoProv {ipName = "sat_s11a_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:11:23-42"}) +Just (InfoProv {ipName = "sat_s11q_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:12:23-46"}) +Just (InfoProv {ipName = "sat_s11G_info", ipDesc = "15", ipTyDesc = "Any", ipLabel = "main", ipMod = "Main", ipLoc = "staticcallstack002.hs:13:23-44"}) diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 2c73973680..c12e8d14ca 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -487,8 +487,14 @@ test('T19381', extra_run_opts('+RTS -T -RTS'), compile_and_run, ['']) test('T20199', normal, makefile_test, []) test('ipeMap', [c_src], compile_and_run, ['']) + test('cloneMyStack', [extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c']) test('cloneMyStack2', ignore_stdout, compile_and_run, ['']) test('cloneMyStack_retBigStackFrame', [extra_files(['cloneStackLib.c']), ignore_stdout], compile_and_run, ['cloneStackLib.c']) - test('cloneThreadStack', [only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded']) +test('decodeMyStack', normal, compile_and_run, ['-finfo-table-map']) +# Options: +# - `-kc8K`: Set stack chunk size to it's minimum to provoke underflow stack frames. +test('decodeMyStack_underflowFrames', [extra_run_opts('+RTS -kc8K -RTS')], compile_and_run, ['-finfo-table-map -rtsopts']) +# -finfo-table-map intentionally missing +test('decodeMyStack_emptyListForMissingFlag', [ignore_stdout, ignore_stderr], compile_and_run, ['']) diff --git a/testsuite/tests/rts/cloneMyStack.hs b/testsuite/tests/rts/cloneMyStack.hs index cdc93e6004..11a69201e0 100644 --- a/testsuite/tests/rts/cloneMyStack.hs +++ b/testsuite/tests/rts/cloneMyStack.hs @@ -16,14 +16,14 @@ foreign import ccall "expectClosureTypes" expectClosureTypes:: StackSnapshot# -> -- snapshot is still valid afterwards (is not gc'ed while in use). main :: IO () main = do - stackSnapshot <- cloneMyStack + stackSnapshot <- cloneMyStack - performMajorGC + performMajorGC - let (StackSnapshot stack) = stackSnapshot - let expectedClosureTypes = [ 30 -- RET_SMALL - , 30 -- RET_SMALL - , 34 -- CATCH_FRAME - , 36 -- STOP_FRAME - ] - withArray expectedClosureTypes (\ptr -> expectClosureTypes stack ptr (length expectedClosureTypes)) + let (StackSnapshot stack) = stackSnapshot + let expectedClosureTypes = [ 30 -- RET_SMALL + , 30 -- RET_SMALL + , 34 -- CATCH_FRAME + , 36 -- STOP_FRAME + ] + withArray expectedClosureTypes (\ptr -> expectClosureTypes stack ptr (length expectedClosureTypes)) diff --git a/testsuite/tests/rts/cloneMyStack2.hs b/testsuite/tests/rts/cloneMyStack2.hs index 068c816ce5..e00a263d80 100644 --- a/testsuite/tests/rts/cloneMyStack2.hs +++ b/testsuite/tests/rts/cloneMyStack2.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} + module Main where import GHC.Stack.CloneStack diff --git a/testsuite/tests/rts/cloneStackLib.c b/testsuite/tests/rts/cloneStackLib.c index a89a069886..c4050c45aa 100644 --- a/testsuite/tests/rts/cloneStackLib.c +++ b/testsuite/tests/rts/cloneStackLib.c @@ -75,7 +75,7 @@ static int countOnes(StgPtr spBottom, StgPtr payload, case CONSTR_0_1: { const StgConInfoTable *con_info = get_con_itbl(closure); if (strcmp(GET_CON_DESC(con_info), "ghc-prim:GHC.Types.I#") == 0 && - closure->payload[0] == 1) { + closure->payload[0] == (StgClosure*) 1) { ones++; } break; diff --git a/testsuite/tests/rts/cloneThreadStack.hs b/testsuite/tests/rts/cloneThreadStack.hs index 11b37d3577..fa2bc66795 100644 --- a/testsuite/tests/rts/cloneThreadStack.hs +++ b/testsuite/tests/rts/cloneThreadStack.hs @@ -19,36 +19,35 @@ foreign import ccall "expectStackToBeNotDirty" expectStackToBeNotDirty:: StackSn -- snapshot is still valid afterwards (is not gc'ed while in use). main :: IO () main = do - mVarToBeBlockedOn <- newEmptyMVar - threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn + mVarToBeBlockedOn <- newEmptyMVar + threadId <- forkIO $ immediatelyBlocking mVarToBeBlockedOn - waitUntilBlocked threadId + waitUntilBlocked threadId - stackSnapshot <- cloneThreadStack threadId + stackSnapshot <- cloneThreadStack threadId - performMajorGC + performMajorGC - let (StackSnapshot stack) = stackSnapshot - let (ThreadId tid#) = threadId - expectStacksToBeEqual stack tid# - expectStackToBeNotDirty stack + let (StackSnapshot stack) = stackSnapshot + let (ThreadId tid#) = threadId + expectStacksToBeEqual stack tid# + expectStackToBeNotDirty stack immediatelyBlocking :: MVar Int -> IO () immediatelyBlocking mVarToBeBlockedOn = do - takeMVar mVarToBeBlockedOn - return () + takeMVar mVarToBeBlockedOn + return () waitUntilBlocked :: ThreadId -> IO () waitUntilBlocked tid = do - blocked <- isBlocked tid - if blocked then - return () - else - do - threadDelay 100000 - waitUntilBlocked tid - -isBlocked:: ThreadId -> IO Bool + blocked <- isBlocked tid + if blocked + then return () + else do + threadDelay 100000 + waitUntilBlocked tid + +isBlocked :: ThreadId -> IO Bool isBlocked = fmap isThreadStatusBlocked . threadStatus isThreadStatusBlocked :: ThreadStatus -> Bool diff --git a/testsuite/tests/rts/decodeMyStack.hs b/testsuite/tests/rts/decodeMyStack.hs new file mode 100644 index 0000000000..b0c330ee34 --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack.hs @@ -0,0 +1,23 @@ +module Main where + +import GHC.Stack.CloneStack +import System.IO.Unsafe + +getDeepStack :: Int -> (Int, [StackEntry]) +getDeepStack deepness = case getDeepStackCase deepness of + [] -> (0, []) + s -> (deepness, s) + where + getDeepStackCase :: Int -> [StackEntry] + getDeepStackCase 0 = + unsafePerformIO $ + ( do + stack <- cloneMyStack + GHC.Stack.CloneStack.decode stack + ) + getDeepStackCase n = snd $ getDeepStack $ n - 1 + +main :: IO () +main = do + let (_, stackEntries) = getDeepStack 10 + mapM_ (putStrLn . show) stackEntries diff --git a/testsuite/tests/rts/decodeMyStack.stdout b/testsuite/tests/rts/decodeMyStack.stdout new file mode 100644 index 0000000000..62d635d0fc --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack.stdout @@ -0,0 +1,12 @@ +StackEntry {functionName = "main.(...)", moduleName = "Main", srcLoc = "decodeMyStack.hs:22:27-41", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:18:26-28", closureType = 53} +StackEntry {functionName = "getDeepStack.getDeepStackCase", moduleName = "Main", srcLoc = "decodeMyStack.hs:13:7-21", closureType = 53} diff --git a/testsuite/tests/rts/decodeMyStack_emptyListForMissingFlag.hs b/testsuite/tests/rts/decodeMyStack_emptyListForMissingFlag.hs new file mode 100644 index 0000000000..d30102ed27 --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack_emptyListForMissingFlag.hs @@ -0,0 +1,24 @@ +module Main where + +import GHC.Stack.CloneStack +import System.IO.Unsafe + +returnFrame :: Int -> [StackEntry] +returnFrame i = case ( unsafePerformIO $ do + stack <- cloneMyStack + stackEntries <- decode stack + pure (i, stackEntries) + ) of + (1, stackEntries) -> stackEntries + _ -> [] + +main :: IO () +main = do + assertEqual (returnFrame 1) [] + return () + +assertEqual :: (Eq a, Show a) => a -> a -> IO () +assertEqual x y = + if x == y + then return () + else error $ "assertEqual: " ++ show x ++ " /= " ++ show y diff --git a/testsuite/tests/rts/decodeMyStack_underflowFrames.hs b/testsuite/tests/rts/decodeMyStack_underflowFrames.hs new file mode 100644 index 0000000000..aca05150d4 --- /dev/null +++ b/testsuite/tests/rts/decodeMyStack_underflowFrames.hs @@ -0,0 +1,67 @@ +module Main where + +import GHC.Stack.CloneStack +import System.IO.Unsafe +import Control.Monad + +getDeepStack :: Int -> (Int, [StackEntry]) +getDeepStack deepness = case getDeepStackCase deepness of + [] -> (0, []) + s -> (deepness, s) + where + getDeepStackCase :: Int -> [StackEntry] + getDeepStackCase 0 = + unsafePerformIO $ + ( do + stack <- cloneMyStack + GHC.Stack.CloneStack.decode stack + ) + getDeepStackCase n = snd $ getDeepStack $ n - 1 + +assertEqual :: (Eq a, Show a) => a -> a -> IO () +assertEqual x y = + if x == y + then return () + else error $ "assertEqual: " ++ show x ++ " /= " ++ show y + +main :: IO () +main = do + let (_, stack) = getDeepStack 1000 + + assertEqual (length stack) 1003 + assertEqual + (stack !! 0) + StackEntry + { functionName = "assertEqual", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:23:11", + closureType = 53 + } + assertEqual + (stack !! 1) + StackEntry + { functionName = "main.(...)", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:29:20-36", + closureType = 53 + } + forM_ + [2 .. 1001] + ( \i -> + assertEqual + (stack !! i) + StackEntry + { functionName = "getDeepStack.getDeepStackCase", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:19:26-28", + closureType = 53 + } + ) + assertEqual + (stack !! 1002) + StackEntry + { functionName = "getDeepStack.getDeepStackCase", + moduleName = "Main", + srcLoc = "decodeMyStack_underflowFrames.hs:14:7-21", + closureType = 53 + } |