diff options
| -rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 24 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 16 | ||||
| -rw-r--r-- | 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 |