diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/StgToCmm.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 50 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Config.hs | 1 |
6 files changed, 54 insertions, 5 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index e1e69a6296..0666b98db4 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -53,6 +53,7 @@ module GHC.Cmm.CLabel ( mkDirty_MUT_VAR_Label, mkMUT_VAR_CLEAN_infoLabel, mkNonmovingWriteBarrierEnabledLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, @@ -641,7 +642,7 @@ mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable -- Constructing Cmm Labels mkDirty_MUT_VAR_Label, mkNonmovingWriteBarrierEnabledLabel, - mkUpdInfoLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, mkMAP_DIRTY_infoLabel, @@ -655,6 +656,7 @@ mkDirty_MUT_VAR_Label, mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData +mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs index 283ece1d50..2a3a64b97c 100644 --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -37,6 +37,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig , stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags , stgToCmmSCCProfiling = sccProfilingEnabled dflags , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags + , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo dflags , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags , stgToCmmOmitYields = gopt Opt_OmitYields dflags , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index f08cb37d43..d67f026fc4 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -329,6 +329,7 @@ data GeneralFlag | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling + | Opt_OrigThunkInfo | Opt_NoHsMain | Opt_SplitSections | Opt_StgStats @@ -565,6 +566,7 @@ codeGenFlags = EnumSet.fromList -- Flags that affect debugging information , Opt_DistinctConstructorTables , Opt_InfoTableMap + , Opt_OrigThunkInfo ] data WarningFlag = diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index dbd1f542ca..e44a543b13 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3482,6 +3482,7 @@ fFlagsDeps = [ flagSpec "do-eta-reduction" Opt_DoEtaReduction, flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 1181ed0597..ce022a092b 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -730,7 +730,8 @@ setupUpdate closure_info node body lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel - pushUpdateFrame lbl (CmmReg (CmmLocal node)) body + pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -738,7 +739,8 @@ setupUpdate closure_info node body ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf node - ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } + ; pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body } else do {tickyUpdateFrameOmitted; body} } @@ -754,8 +756,7 @@ pushUpdateFrame lbl updatee body = do updfr <- getUpdFrameOff profile <- getProfile - let - hdr = fixedHdrSize profile + let hdr = fixedHdrSize profile frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) -- emitUpdateFrame (CmmStackSlot Old frame) lbl updatee @@ -774,6 +775,47 @@ emitUpdateFrame frame lbl updatee = do initUpdFrameProf frame ----------------------------------------------------------------------------- +-- Original thunk info table frames +-- +-- Note [Original thunk info table frames] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very +-- useful to know which thunks the program is in the process of evaluating. +-- However, in the case of updateable thunks this can be very difficult +-- to determine since the process of blackholing overwrites the thunk's +-- info table pointer. +-- +-- To help in such situations we provide the -forig-thunk-info flag. This enables +-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to +-- accompany each update frame. As the name suggests, this frame captures the +-- the original info table of the thunk being updated. The entry code for these +-- frames has no operational effects; the frames merely exist as breadcrumbs +-- for debugging. + +pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode () +pushOrigThunkInfoFrame closure_info body = do + cfg <- getStgToCmmConfig + if stgToCmmOrigThunkInfo cfg + then do_it + else body + where + orig_itbl = mkLblExpr (closureInfoLabel closure_info) + do_it = do + updfr <- getUpdFrameOff + profile <- getProfile + let platform = profilePlatform profile + hdr = fixedHdrSize profile + orig_info_frame_sz = + hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile) + off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile) + frame_off = updfr + orig_info_frame_sz + frame = CmmStackSlot Old frame_off + -- + emitStore frame (mkLblExpr mkOrigThunkInfoLabel) + emitStore (cmmOffset platform frame off_orig_info) orig_itbl + withUpdFrameOff frame_off body + +----------------------------------------------------------------------------- -- Entering a CAF -- -- See Note [CAF management] in rts/sm/Storage.c diff --git a/compiler/GHC/StgToCmm/Config.hs b/compiler/GHC/StgToCmm/Config.hs index f2bd349ae7..f6ec53c760 100644 --- a/compiler/GHC/StgToCmm/Config.hs +++ b/compiler/GHC/StgToCmm/Config.hs @@ -49,6 +49,7 @@ data StgToCmmConfig = StgToCmmConfig , stgToCmmFastPAPCalls :: !Bool -- ^ , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled , stgToCmmEagerBlackHole :: !Bool -- ^ + , stgToCmmOrigThunkInfo :: !Bool -- ^ Push @stg_orig_thunk_info@ frames during thunk update. , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See note [Mapping -- Info Tables to Source Positions] , stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed |