From 1f6c56ae9aa4ab4977ba376ac901d5256bf0aba0 Mon Sep 17 00:00:00 2001 From: Andreas Klebinger Date: Fri, 8 Jul 2022 23:18:04 +0200 Subject: StgToCmm: Fix isSimpleScrut when profiling is enabled. When profiling is enabled we must enter functions that might represent thunks in order for their sccs to show up in the profile. We might allocate even if the function is already evaluated in this case. So we can't consider any potential function thunk to be a simple scrut when profiling. Not doing so caused profiled binaries to segfault. --- compiler/GHC/StgToCmm/Closure.hs | 24 ++++++------------------ compiler/GHC/StgToCmm/Expr.hs | 16 +++++++--------- compiler/GHC/Types/RepType.hs | 19 +++++++++++++++++++ 3 files changed, 32 insertions(+), 27 deletions(-) diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index d935bb4b99..fc76664d94 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -208,7 +208,7 @@ argPrimRep arg = typePrimRep1 (stgArgType arg) mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id | isUnliftedType ty = LFUnlifted - | might_be_a_function ty = LFUnknown True + | mightBeFunTy ty = LFUnknown True | otherwise = LFUnknown False where ty = idType id @@ -236,19 +236,7 @@ mkLFThunk thunk_ty top fvs upd_flag LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk - (might_be_a_function thunk_ty) - --------------- -might_be_a_function :: Type -> Bool --- Return False only if we are *sure* it's a data type --- Look through newtypes etc as much as poss -might_be_a_function ty - | [LiftedRep] <- typePrimRep ty - , Just tc <- tyConAppTyCon_maybe (unwrapType ty) - , isDataTyCon tc - = False - | otherwise - = True + (mightBeFunTy thunk_ty) ------------- mkConLFInfo :: DataCon -> LambdaFormInfo @@ -258,13 +246,13 @@ mkConLFInfo con = LFCon con mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo mkSelectorLFInfo id offset updatable = LFThunk NotTopLevel False updatable (SelectorThunk offset) - (might_be_a_function (idType id)) + (mightBeFunTy (idType id)) ------------- mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) - (might_be_a_function (idType id)) + (mightBeFunTy (idType id)) ------------- mkLFImported :: Id -> LambdaFormInfo @@ -597,8 +585,8 @@ getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_loc | n_args == 0 , Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by Tag Inference - -- When profiling we enter functions to update the SCC so we - -- can't use the infered enterInfo here. + -- When profiling we must enter all potential functions to make sure we update the SCC + -- even if the function itself is already evaluated. -- See Note [Evaluating functions with profiling] in rts/Apply.cmm , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function) = InferedReturnIt -- See Note [Tag Inference] diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 9494a3c57d..0e7c52f68d 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -45,7 +45,7 @@ import GHC.Types.Id import GHC.Builtin.PrimOps import GHC.Core.TyCon import GHC.Core.Type ( isUnliftedType ) -import GHC.Types.RepType ( isZeroBitTy, countConRepArgs ) +import GHC.Types.RepType ( isZeroBitTy, countConRepArgs, mightBeFunTy ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS ) import GHC.Types.Tickish import GHC.Data.Maybe @@ -59,6 +59,7 @@ import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List ( partition ) import GHC.Stg.InferTags.TagSig (isTaggedSig) +import GHC.Platform.Profile (profileIsProfiling) ------------------------------------------------------------------------ -- cgExpr: the main function @@ -551,7 +552,6 @@ cgCase scrut bndr alt_type alts | not simple_scrut = True | isSingleton alts = False | up_hp_usg > 0 = False - | evaluatedScrut = False | otherwise = True -- cf Note [Compiling case expressions] gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts @@ -567,12 +567,6 @@ cgCase scrut bndr alt_type alts where is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op is_cmp_op _ = False - evaluatedScrut - | (StgApp v []) <- scrut - , Just sig <- idTagSig_maybe v - , isTaggedSig sig = True - | otherwise = False - {- Note [GC for conditionals] @@ -628,7 +622,11 @@ isSimpleScrut (StgLit _) _ = return True -- case 1# of { isSimpleScrut (StgApp _ []) (PrimAlt _) = return True -- case x# of { 0# -> ..; ... } isSimpleScrut (StgApp f []) _ | Just sig <- idTagSig_maybe f - = return $! isTaggedSig sig -- case !x of { ... } + , isTaggedSig sig -- case !x of { ... } + = if mightBeFunTy (idType f) + -- See Note [Evaluating functions with profiling] in rts/Apply.cmm + then not . profileIsProfiling <$> getProfile + else pure True isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 2c0d93afb5..4aca238713 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -22,6 +22,9 @@ module GHC.Types.RepType ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), slotPrimRep, primRepSlot, + -- * Is this type known to be data? + mightBeFunTy + ) where import GHC.Prelude @@ -674,3 +677,19 @@ primRepToRuntimeRep rep = case rep of -- See also Note [RuntimeRep and PrimRep] primRepToType :: PrimRep -> Type primRepToType = anyTypeOfKind . mkTYPEapp . primRepToRuntimeRep + +-------------- +mightBeFunTy :: Type -> Bool +-- Return False only if we are *sure* it's a data type +-- Look through newtypes etc as much as possible. Used to +-- decide if we need to enter a closure via a slow call. +-- +-- AK: It would be nice to figure out and document the difference +-- between this and isFunTy at some point. +mightBeFunTy ty + | [LiftedRep] <- typePrimRep ty + , Just tc <- tyConAppTyCon_maybe (unwrapType ty) + , isDataTyCon tc + = False + | otherwise + = True -- cgit v1.2.1