diff options
| -rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 24 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 15 | ||||
| -rw-r--r-- | compiler/GHC/Types/RepType.hs | 19 |
3 files changed, 31 insertions, 27 deletions
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 7c1b5250e4..1933474392 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -209,7 +209,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 @@ -237,19 +237,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 @@ -259,13 +247,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 @@ -598,8 +586,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 7992e34417..98f315db75 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -46,7 +46,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 @@ -60,6 +60,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 @@ -552,7 +553,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 @@ -568,12 +568,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] @@ -629,7 +623,10 @@ 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) + 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 0d6d6b076c..7a854e4d5c 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 @@ -677,3 +680,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 |