diff options
| author | Sebastian Graf <sebastian.graf@kit.edu> | 2021-03-26 11:54:25 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-28 00:12:21 -0400 |
| commit | b02c8ef768df33ef4845da2f15583cf143a4d0e2 (patch) | |
| tree | 93cc9890baaf66d43818572e9d897687438a84c1 /compiler | |
| parent | f6960b188f4e66bb1c7b00d55a015fdd418614a7 (diff) | |
| download | haskell-b02c8ef768df33ef4845da2f15583cf143a4d0e2.tar.gz | |
Rename StrictSig to DmdSig (#19597)
In #19597, we also settled on the following renamings:
* `idStrictness` -> `idDmdSig`,
`strictnessInfo` -> `dmdSigInfo`,
`HsStrictness` -> `HsDmdSig`
* `idCprInfo` -> `idCprSig`,
`cprInfo` -> `cprSigInfo`,
`HsCpr` -> `HsCprSig`
Fixes #19597.
Diffstat (limited to 'compiler')
31 files changed, 256 insertions, 256 deletions
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 14040692bc..58d0c9e76b 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -130,8 +130,8 @@ mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty Not all primops are strict! -} -primOpStrictness :: PrimOp -> Arity -> StrictSig - -- See Demand.StrictnessInfo for discussion of what the results +primOpStrictness :: PrimOp -> Arity -> DmdSig + -- See Demand.DmdSig for discussion of what the results -- The arity should be the arity of the primop; that's why -- this function isn't exported. #include "primop-strictness.hs-incl" @@ -678,7 +678,7 @@ isComparisonPrimOp op = case primOpInfo op of -- (type variables, argument types, result type) -- It also gives arity, strictness info -primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, DmdSig) primOpSig op = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) where diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index c11cc05a40..a00f3f8215 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -142,7 +142,7 @@ defaults can_fail = False -- See Note [PrimOp can_fail and has_side_effects] in PrimOp commutable = False code_size = { primOpCodeSizeDefault } - strictness = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topDiv } + strictness = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv } fixity = Nothing llvm_only = False vector = [] @@ -2455,7 +2455,7 @@ primop CatchOp "catch#" GenPrimOp -> State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] @@ -2473,7 +2473,7 @@ primop RaiseOp "raise#" GenPrimOp -- For the same reasons, 'raise#' is marked as "can_fail" (which 'raiseIO#' -- is not), but not as "has_side_effects" (which 'raiseIO#' is). -- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps". - strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } out_of_line = True can_fail = True @@ -2482,7 +2482,7 @@ primop RaiseIOOp "raiseIO#" GenPrimOp with -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" -- for why this is the *only* primop that has 'exnDiv' - strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnDiv } + strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv } out_of_line = True has_side_effects = True @@ -2490,7 +2490,7 @@ primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2499,7 +2499,7 @@ primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } out_of_line = True has_side_effects = True @@ -2507,7 +2507,7 @@ primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2528,7 +2528,7 @@ primop AtomicallyOp "atomically#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ _arity -> mkClosedStrictSig [strictManyApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2546,7 +2546,7 @@ primop AtomicallyOp "atomically#" GenPrimOp primop RetryOp "retry#" GenPrimOp State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } out_of_line = True has_side_effects = True @@ -2555,7 +2555,7 @@ primop CatchRetryOp "catchRetry#" GenPrimOp -> (State# RealWorld -> (# State# RealWorld, a #) ) -> (State# RealWorld -> (# State# RealWorld, a #) ) with - strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply1Dmd , topDmd ] topDiv } -- See Note [Strictness for mask/unmask/catch] @@ -2567,7 +2567,7 @@ primop CatchSTMOp "catchSTM#" GenPrimOp -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) -> (State# RealWorld -> (# State# RealWorld, a #) ) with - strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd ] topDiv } -- See Note [Strictness for mask/unmask/catch] @@ -3135,7 +3135,7 @@ primop KeepAliveOp "keepAlive#" GenPrimOp o -> State# RealWorld -> (State# RealWorld -> p) -> p { TODO. } with - strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv } + strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv } ------------------------------------------------------------------------ @@ -3147,7 +3147,7 @@ section "Tag to enum stuff" primop DataToTagOp "dataToTag#" GenPrimOp a -> Int# -- Zero-indexed; the first constructor has tag zero with - strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topDiv } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } -- See Note [dataToTag# magic] in GHC.Core.Op.ConstantFold primop TagToEnumOp "tagToEnum#" GenPrimOp diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index a3ea0bb1d3..078d8492ff 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -81,7 +81,7 @@ import GHC.Utils.Misc import GHC.Core.InstEnv ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity ) -import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv ) +import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) import GHC.Types.TypeEnv import GHC.Unit.Module.ModGuts import GHC.Runtime.Context @@ -677,12 +677,12 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty ppr (length (typeArity (idType binder))) <> colon <+> ppr binder) - ; case splitStrictSig (idStrictness binder) of + ; case splitDmdSig (idDmdSig binder) of (demands, result_info) | isDeadEndDiv result_info -> checkL (demands `lengthAtLeast` idArity binder) (text "idArity" <+> ppr (idArity binder) <+> text "exceeds arity imposed by the strictness signature" <+> - ppr (idStrictness binder) <> colon <+> + ppr (idDmdSig binder) <> colon <+> ppr binder) _ -> return () diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 60ae13bee7..3638b43c56 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -897,8 +897,8 @@ mkExceptionId :: Name -> Id mkExceptionId name = mkVanillaGlobalWithInfo name (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a - (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv - `setCprInfo` mkCprSig 0 botCpr + (vanillaIdInfo `setDmdSigInfo` mkClosedDmdSig [] botDiv + `setCprSigInfo` mkCprSig 0 botCpr `setArityInfo` 0 `setCafInfo` NoCafRefs) -- #15038 @@ -912,8 +912,8 @@ mkRuntimeErrorId :: Name -> Id mkRuntimeErrorId name = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info where - bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig - `setCprInfo` mkCprSig 1 botCpr + bottoming_info = vanillaIdInfo `setDmdSigInfo` strict_sig + `setCprSigInfo` mkCprSig 1 botCpr `setArityInfo` 1 -- Make arity and strictness agree @@ -926,7 +926,7 @@ mkRuntimeErrorId name -- any pc_bottoming_Id will itself have CafRefs, which bloats -- SRTs. - strict_sig = mkClosedStrictSig [evalDmd] botDiv + strict_sig = mkClosedDmdSig [evalDmd] botDiv runtimeErrorTy :: Type -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index ec450ec245..36a2535c09 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -171,7 +171,7 @@ typeArity ty = [] --------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig) -- A cheap and cheerful function that identifies bottoming functions -- and gives them a suitable strictness signatures. It's used during -- float-out @@ -180,7 +180,7 @@ exprBotStrictness_maybe e Nothing -> Nothing Just ar -> Just (ar, sig ar) where - sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv + sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv {- Note [exprArity invariant] @@ -1095,9 +1095,9 @@ environment mapping let-bound Ids to their ArityType. idArityType :: Id -> ArityType idArityType v - | strict_sig <- idStrictness v + | strict_sig <- idDmdSig v , not $ isTopSig strict_sig - , (ds, div) <- splitStrictSig strict_sig + , (ds, div) <- splitDmdSig strict_sig , let arity = length ds -- Every strictness signature admits an arity signature! = AT (take arity one_shots) div diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index f54962b7cd..53b5983758 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -706,7 +706,7 @@ trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] | isDeadEndDiv result_info = length demands | otherwise = a - (demands, result_info) = splitStrictSig (idStrictness v) + (demands, result_info) = splitDmdSig (idDmdSig v) --------------------------------------- -- Functions related to CallArityRes -- diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index be3fa73282..cd4c310b3a 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -114,7 +114,7 @@ cprAnalProgram logger dflags fam_envs binds = do let env = emptyAnalEnv fam_envs let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ - dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr + dumpIdInfoOfProgram (ppr . cprSigInfo) binds_plus_cpr -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_cpr `seq` return binds_plus_cpr @@ -252,7 +252,7 @@ cprTransform env id = fst $ cprAnal env rhs -- Imported function or data con worker | isGlobalId id - = getCprSig (idCprInfo id) + = getCprSig (idCprSig id) | otherwise = topCprType @@ -274,11 +274,11 @@ cprFix top_lvl orig_env orig_pairs | otherwise = mkCprSig 0 botCpr -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal orig_virgin = ae_virgin orig_env - init_pairs | orig_virgin = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ] + init_pairs | orig_virgin = [(setIdCprSig id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ] | otherwise = orig_pairs init_env = extendSigEnvFromIds orig_env (map fst init_pairs) - -- The fixed-point varies the idCprInfo field of the binders and and their + -- The fixed-point varies the idCprSig field of the binders and and their -- entries in the AnalEnv, and terminates if that annotation does not change -- any more. loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) @@ -291,7 +291,7 @@ cprFix top_lvl orig_env orig_pairs (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs -- Make sure we reset the virgin flag to what it was when we are stable reset_env' = env'{ ae_virgin = orig_virgin } - found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs + found_fixpoint = map (idCprSig . fst) pairs' == map (idCprSig . fst) pairs step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)]) step env pairs = mapAccumL go env pairs @@ -325,7 +325,7 @@ cprAnalBind top_lvl env id rhs | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' - id' = setIdCprInfo id sig + id' = setIdCprSig id sig env' = extendSigEnv env id sig -- See Note [CPR for thunks] @@ -452,7 +452,7 @@ extendSigEnvList env ids_cprs -- | Extend an environment with the CPR sigs attached to the ids extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv extendSigEnvFromIds env ids - = foldl' (\env id -> extendSigEnv env id (idCprInfo id)) env ids + = foldl' (\env id -> extendSigEnv env id (idCprSig id)) env ids -- | Extend an environment with the same CPR sig for all ids extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index eedc9b4489..d1bbc232c7 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -220,7 +220,7 @@ position. -- -- It calls a function that knows how to analyse this \"body\" given -- an 'AnalEnv' with updated demand signatures for the binding group --- (reflecting their 'idStrictnessInfo') and expects to receive a +-- (reflecting their 'idDmdSigInfo') and expects to receive a -- 'DmdType' in return, which it uses to annotate the binding group with their -- 'idDemandInfo'. dmdAnalBind @@ -701,11 +701,11 @@ dmdTransform env var dmd -- See #18429 for some perf measurements. | Just _ <- isClassOpId_maybe var = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $ - dmdTransformDictSelSig (idStrictness var) dmd + dmdTransformDictSelSig (idDmdSig var) dmd -- Imported functions | isGlobalId var - , let res = dmdTransformSig (idStrictness var) dmd - = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + , let res = dmdTransformSig (idDmdSig var) dmd + = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr dmd, ppr res]) res -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). -- In that case, we have a strictness signature to unleash in our AnalEnv. @@ -772,9 +772,9 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty - sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) + sig = mkDmdSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) - id' = id `setIdStrictness` sig + id' = id `setIdDmdSig` sig env' = extendAnalEnv top_lvl env id' sig -- See Note [Aggregated demand for cardinality] @@ -901,7 +901,7 @@ trivial RHS (see Note [Demand analysis for trivial right-hand sides]). Because idArity of a function varies independently of its cardinality properties (cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode the arity for when a demand signature is sound to unleash -in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and StrictSig] in +in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when the incoming number of arguments is less than that. See Note [What are demand signatures?] in GHC.Types.Demand for more details @@ -950,7 +950,7 @@ reset or decrease arity. That's an unnecessary dependency, because * idArity is analysis information itself, thus volatile * We already *have* dmdTypeDepth, wo why not just use it to encode the threshold for when to unleash the signature - (cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand) + (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand) Consider the following expression, for example: @@ -1062,23 +1062,23 @@ dmdFix top_lvl env let_dmd orig_pairs = loop 1 initial_pairs where -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ] + initial_pairs | ae_virgin env = [(setIdDmdSig id botSig, rhs) | (id, rhs) <- orig_pairs ] | otherwise = orig_pairs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)]) abort = (env, lazy_fv', zapped_pairs) - where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs) + where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs) -- Note [Lazy and unleashable free variables] - non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs' + non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs' lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs - zapped_pairs = zapIdStrictness pairs' + zapped_pairs = zapIdDmdSig pairs' - -- The fixed-point varies the idStrictness field of the binders, and terminates if that + -- The fixed-point varies the idDmdSig field of the binders, and terminates if that -- annotation does not change any more. loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id) + loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) -- | (id,_)<- pairs]) $ loop' n pairs @@ -1087,7 +1087,7 @@ dmdFix top_lvl env let_dmd orig_pairs | n == 10 = abort | otherwise = loop (n+1) pairs' where - found_fixpoint = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs + found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs first_round = n == 1 (lazy_fv, pairs') = step first_round pairs final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') @@ -1107,14 +1107,14 @@ dmdFix top_lvl env let_dmd orig_pairs -- so this can significantly reduce the number of iterations needed my_downRhs (env, lazy_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $ + = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ ((env', lazy_fv'), (id', rhs')) where (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1 - zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ] + zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] + zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1379,7 +1379,7 @@ data AnalEnv = AE -- The DmdEnv gives the demand on the free vars of the function -- when it is given enough args to satisfy the strictness signature -type SigEnv = VarEnv (StrictSig, TopLevelFlag) +type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat @@ -1406,16 +1406,16 @@ extendAnalEnvs top_lvl env vars extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars] + = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv +extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } -extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv +extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) -lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) +lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id nonVirgin :: AnalEnv -> AnalEnv diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 3861b3e462..83c44dcec2 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2110,7 +2110,7 @@ occAnalApp env (Var fun_id, args, ticks) -- See Note [CONLIKE pragma] in GHC.Types.Basic -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs - one_shots = argsOneShots (idStrictness fun_id) guaranteed_val_args + one_shots = argsOneShots (idDmdSig fun_id) guaranteed_val_args guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo (occ_one_shots env)) -- See Note [Sources of one-shot information], bullet point A'] diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index d3dcfb3263..2334436d69 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -1096,8 +1096,8 @@ transferIdInfo exported_id local_id , local_id `setInlinePragma` defaultInlinePragma ) where local_info = idInfo local_id - transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info - `setCprInfo` cprInfo local_info + transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info + `setCprSigInfo` cprSigInfo local_info `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info @@ -1115,6 +1115,6 @@ dmdAnal logger dflags fam_envs rules binds = do } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ - dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds + dumpIdInfoOfProgram (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_dmds `seq` return binds_plus_dmds diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 2ea0c8606d..e18c7d3e82 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -103,7 +103,7 @@ import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) -import GHC.Types.Demand ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig ) +import GHC.Types.Demand ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) @@ -446,7 +446,7 @@ lvlApp env orig_expr ((_,AnnVar fn), args) arity = idArity fn stricts :: [Demand] -- True for strict /value/ arguments - stricts = case splitStrictSig (idStrictness fn) of + stricts = case splitDmdSig (idDmdSig fn) of (arg_ds, _) | arg_ds `lengthExceeds` n_val_args -> [] | otherwise @@ -822,7 +822,7 @@ Exammples: t = f (g True) If f is lazy, we /do/ float (g True) because then we can allocate the thunk statically rather than dynamically. But if f is strict - we don't (see the use of idStrictness in lvlApp). It's not clear + we don't (see the use of idDmdSig in lvlApp). It's not clear if this test is worth the bother: it's only about CAFs! It's controlled by a flag (floatConsts), because doing this too @@ -1024,7 +1024,7 @@ answer. -} -annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id +annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id -- See Note [Bottoming floats] for why we want to add -- bottoming information right now -- @@ -1033,8 +1033,8 @@ annotateBotStr id n_extra mb_str = case mb_str of Nothing -> id Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdStrictness` (prependArgsStrictSig n_extra sig) - `setIdCprInfo` mkCprSig (arity + n_extra) botCpr + `setIdDmdSig` (prependArgsDmdSig n_extra sig) + `setIdCprSig` mkCprSig (arity + n_extra) botCpr notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 701573a55d..5daa7fc157 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -42,8 +42,8 @@ import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) import GHC.Core import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey ) -import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd - , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv ) +import GHC.Types.Demand ( DmdSig(..), Demand, dmdTypeDepth, isStrUsedDmd + , mkClosedDmdSig, topDmd, seqDmd, isDeadEndDiv ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Types.Unique ( hasKey ) @@ -579,8 +579,8 @@ prepareBinding env top_lvl old_bndr bndr rhs ; return (floats, bndr, rhs') } where info = idInfo bndr - worker_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info - `setCprInfo` cprInfo info + worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info `setDemandInfo` demandInfo info `setInlinePragInfo` inlinePragInfo info `setArityInfo` arityInfo info @@ -852,18 +852,18 @@ addLetBndrInfo new_bndr new_arity_type new_unf -- eta-expansion *reduces* the arity of the binding to less -- than that of the strictness sig. This can happen: see Note [Arity decrease]. info3 | isEvaldUnfolding new_unf - || (case strictnessInfo info2 of - StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) + || (case dmdSigInfo info2 of + DmdSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty) = zapDemandInfo info2 `orElse` info2 | otherwise = info2 -- Bottoming bindings: see Note [Bottoming bindings] - info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig - `setCprInfo` bot_cpr + info4 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig + `setCprSigInfo` bot_cpr | otherwise = info3 - bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div + bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div bot_cpr = mkCprSig new_arity botCpr -- Zap call arity info. We have used it by now (via @@ -1281,7 +1281,7 @@ simplTick env tickish expr cont -- do { let (inc,outc) = splitCont cont -- ; (env', expr') <- simplExprF (zapFloats env) expr inc -- ; let tickish' = simplTickish env tickish --- ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0), +-- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), -- mkTick (mkNoCount tickish') rhs) -- -- when wrapping a float with mkTick, we better zap the Id's -- -- strictness info and arity, because it might be wrong now. diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index a14e8b24a9..7b22c7881d 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -547,7 +547,7 @@ mkArgInfo env fun rules n_val_args call_cont = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] | otherwise = -- add_type_str fun_ty $ - case splitStrictSig (idStrictness fun) of + case splitDmdSig (idDmdSig fun) of (demands, result_info) | not (demands `lengthExceeds` n_val_args) -> -- Enough args, use the strictness given. diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 4beed6d061..db4701d45a 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1716,7 +1716,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) -- Usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args - spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args + spec_lam_args_str = handOutStrictnessInformation (fst (splitDmdSig spec_str)) spec_lam_args -- Annotate the variables with the strictness information from -- the function (see Note [Strictness information in worker binders]) @@ -1725,8 +1725,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) spec_id = mkLocalId spec_name Many (mkLamTypes spec_lam_args body_ty) -- See Note [Transfer strictness] - `setIdStrictness` spec_str - `setIdCprInfo` topCprSig + `setIdDmdSig` spec_str + `setIdCprSig` topCprSig `setIdArity` count isId spec_lam_args `asJoinId_maybe` spec_join_arity spec_str = calcSpecStrictness fn spec_lam_args pats @@ -1757,13 +1757,13 @@ handOutStrictnessInformation = go calcSpecStrictness :: Id -- The original function -> [Var] -> [CoreExpr] -- Call pattern - -> StrictSig -- Strictness of specialised thing + -> DmdSig -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats - = mkClosedStrictSig spec_dmds div + = mkClosedDmdSig spec_dmds div where spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] - StrictSig (DmdType _ dmds div) = idStrictness fn + DmdSig (DmdType _ dmds div) = idDmdSig fn dmd_env = go emptyVarEnv dmds pats diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 030cb2ac8a..2ee334b9f8 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -511,9 +511,9 @@ tryWW dflags fam_envs is_rec fn_id rhs where uf_opts = unfoldingOpts dflags fn_info = idInfo fn_id - (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) + (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) - cpr_ty = getCprSig (cprInfo fn_info) + cpr_ty = getCprSig (cprSigInfo fn_info) -- Arity of the CPR sig should match idArity when it's not a join point. -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info @@ -584,7 +584,7 @@ divergence, it's also broken for newtypes: where co :: (Int -> Int -> Char) ~ T -Then idArity is 2 (despite the type T), and it can have a StrictSig based on a +Then idArity is 2 (despite the type T), and it can have a DmdSig based on a threshold of 2. But we can't w/w it without a type error. The situation is less grave for PAPs, but the implicit eta expansion caused a @@ -679,11 +679,11 @@ mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding -- See Note [Worker-wrapper for INLINABLE functions] - `setIdStrictness` mkClosedStrictSig work_demands div + `setIdDmdSig` mkClosedDmdSig work_demands div -- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv - `setIdCprInfo` mkCprSig work_arity work_cpr_info + `setIdCprSig` mkCprSig work_arity work_cpr_info `setIdDemandInfo` worker_demand diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index a55b545b0a..fd183fba20 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -508,7 +508,7 @@ instance Outputable IdInfo where caf_info = cafInfo info has_caf_info = not (mayHaveCafRefs caf_info) - str_info = strictnessInfo info + str_info = dmdSigInfo info has_str_info = not (isTopSig str_info) unf_info = unfoldingInfo info @@ -552,10 +552,10 @@ ppIdInfo id info caf_info = cafInfo info has_caf_info = not (mayHaveCafRefs caf_info) - str_info = strictnessInfo info + str_info = dmdSigInfo info has_str_info = not (isTopSig str_info) - cpr_info = cprInfo info + cpr_info = cprSigInfo info has_cpr_info = cpr_info /= topCprSig unf_info = unfoldingInfo info diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 6dfbfef768..129b87f932 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -14,7 +14,7 @@ import GHC.Prelude import GHC.Core import GHC.Types.Id.Info -import GHC.Types.Demand( seqDemand, seqStrictSig ) +import GHC.Types.Demand( seqDemand, seqDmdSig ) import GHC.Types.Cpr( seqCprSig ) import GHC.Types.Basic( seqOccInfo ) import GHC.Types.Tickish @@ -35,8 +35,8 @@ megaSeqIdInfo info -- seqUnfolding (unfoldingInfo info) `seq` seqDemand (demandInfo info) `seq` - seqStrictSig (strictnessInfo info) `seq` - seqCprSig (cprInfo info) `seq` + seqDmdSig (dmdSigInfo info) `seq` + seqCprSig (cprSigInfo info) `seq` seqCaf (cafInfo info) `seq` seqOneShot (oneShotInfo info) `seq` seqOccInfo (occInfo info) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 90cd3f039e..9e3e92d247 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -40,7 +40,7 @@ import GHC.Types.Var ( isNonCoVarId ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.DataCon -import GHC.Types.Demand( etaConvertStrictSig ) +import GHC.Types.Demand( etaConvertDmdSig ) import GHC.Types.Tickish import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList @@ -828,10 +828,10 @@ joinPointBinding_maybe bndr rhs | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs - , let str_sig = idStrictness bndr + , let str_sig = idDmdSig bndr str_arity = count isId bndrs -- Strictness demands are for Ids only join_bndr = bndr `asJoinId` join_arity - `setIdStrictness` etaConvertStrictSig str_arity str_sig + `setIdDmdSig` etaConvertDmdSig str_arity str_sig = Just (join_bndr, mkLams bndrs body) | otherwise diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 61f98e20a4..2cb8eb5471 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -208,7 +208,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id new_info = vanillaIdInfo `setOccInfo` occInfo old_info `setArityInfo` arityInfo old_info - `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info) + `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) `setDemandInfo` demandInfo old_info `setInlinePragInfo` inlinePragInfo old_info `setUnfoldingInfo` new_unf diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 8fdbc1b891..cc95b3536e 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -991,7 +991,7 @@ certainlyWillInline opts fn_info -- See Note [certainlyWillInline: INLINABLE] do_cunf expr size args src' | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] - , not (isDeadEndSig (strictnessInfo fn_info)) + , not (isDeadEndSig (dmdSigInfo fn_info)) -- Do not unconditionally inline a bottoming functions even if -- it seems smallish. We've carefully lifted it out to top level, -- so we don't want to re-inline it. diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs index d9b541e49c..54e44cfe04 100644 --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -30,7 +30,7 @@ import GHC.Core.DataCon import GHC.Core.Utils import GHC.Types.Basic import GHC.Types.Id -import GHC.Types.Demand ( StrictSig, isDeadEndSig ) +import GHC.Types.Demand ( DmdSig, isDeadEndSig ) import GHC.Utils.Outputable import GHC.Utils.Misc @@ -41,7 +41,7 @@ import {-# SOURCE #-} GHC.Core.SimpleOpt -mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding +mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding -- "Final" in the sense that this is a GlobalId that will not be further -- simplified; so the unfolding should be occurrence-analysed mkFinalUnfolding opts src strict_sig expr diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index a4587d58ee..307dfd4893 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -469,13 +469,13 @@ toIfaceIdInfo id_info ------------ Strictness -------------- -- No point in explicitly exporting TopSig - sig_info = strictnessInfo id_info - strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) + sig_info = dmdSigInfo id_info + strict_hsinfo | not (isTopSig sig_info) = Just (HsDmdSig sig_info) | otherwise = Nothing ------------ CPR -------------- - cpr_info = cprInfo id_info - cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info) + cpr_info = cprSigInfo id_info + cpr_hsinfo | cpr_info /= topCprSig = Just (HsCprSig cpr_info) | otherwise = Nothing ------------ Unfolding -------------- unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index af94cb92d7..2e2c4d84af 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -849,8 +849,8 @@ cpeApp top_env expr ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts ; mb_saturate hd app floats depth } where - stricts = case idStrictness v of - StrictSig (DmdType _ demands _) + stricts = case idDmdSig v of + DmdSig (DmdType _ demands _) | listLengthCmp demands depth /= GT -> demands -- length demands <= depth | otherwise -> [] @@ -1345,7 +1345,7 @@ Note [Speculative evaluation] Since call-by-value is much cheaper than call-by-need, we case-bind arguments that are either - 1. Strictly evaluated anyway, according to the StrictSig of the callee, or + 1. Strictly evaluated anyway, according to the DmdSig of the callee, or 2. ok-for-spec, according to 'exprOkForSpeculation' While (1) is a no-brainer and always beneficial, (2) is a bit diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 908d105de0..dfc39fb244 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -346,8 +346,8 @@ type IfaceIdInfo = [IfaceInfoItem] data IfaceInfoItem = HsArity Arity - | HsStrictness StrictSig - | HsCpr CprSig + | HsDmdSig DmdSig + | HsCprSig CprSig | HsInline InlinePragma | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] @@ -1463,8 +1463,8 @@ instance Outputable IfaceInfoItem where <> colon <+> ppr unf ppr (HsInline prag) = text "Inline:" <+> ppr prag ppr (HsArity arity) = text "Arity:" <+> int arity - ppr (HsStrictness str) = text "Strictness:" <+> ppr str - ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr + ppr (HsDmdSig str) = text "Strictness:" <+> ppr str + ppr (HsCprSig cpr) = text "CPR:" <+> ppr cpr ppr HsNoCafRefs = text "HasNoCafRefs" ppr HsLevity = text "Never levity-polymorphic" ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info @@ -2224,26 +2224,26 @@ instance Binary IfaceIdDetails where instance Binary IfaceInfoItem where put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsDmdSig ab) = putByte bh 1 >> put_ bh ab put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad put_ bh HsNoCafRefs = putByte bh 4 put_ bh HsLevity = putByte bh 5 - put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr + put_ bh (HsCprSig cpr) = putByte bh 6 >> put_ bh cpr put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info get bh = do h <- getByte bh case h of 0 -> liftM HsArity $ get bh - 1 -> liftM HsStrictness $ get bh + 1 -> liftM HsDmdSig $ get bh 2 -> do lb <- get bh ad <- get bh return (HsUnfold lb ad) 3 -> liftM HsInline $ get bh 4 -> return HsNoCafRefs 5 -> return HsLevity - 6 -> HsCpr <$> get bh + 6 -> HsCprSig <$> get bh _ -> HsLFInfo <$> get bh instance Binary IfaceUnfolding where @@ -2579,12 +2579,12 @@ instance NFData IfaceIdDetails where instance NFData IfaceInfoItem where rnf = \case HsArity a -> rnf a - HsStrictness str -> seqStrictSig str + HsDmdSig str -> seqDmdSig str HsInline p -> p `seq` () -- TODO: seq further? HsUnfold b unf -> rnf b `seq` rnf unf HsNoCafRefs -> () HsLevity -> () - HsCpr cpr -> cpr `seq` () + HsCprSig cpr -> cpr `seq` () HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further? instance NFData IfaceUnfolding where diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index fa6db60736..c6175b2602 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -734,7 +734,7 @@ addExternal omit_prags expose_all id show_unfold = show_unfolding unfolding never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isStrongLoopBreaker (occInfo idinfo) - bottoming_fn = isDeadEndSig (strictnessInfo idinfo) + bottoming_fn = isDeadEndSig (dmdSigInfo idinfo) -- Stuff to do with the Id's unfolding -- We leave the unfolding there even if there is a worker @@ -1190,16 +1190,16 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold -- Arity and strictness info are enough; -- c.f. GHC.Core.Tidy.tidyLetBndr `setArityInfo` arity - `setStrictnessInfo` final_sig - `setCprInfo` final_cpr + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] -- in GHC.Core.Tidy | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo `setArityInfo` arity - `setStrictnessInfo` final_sig - `setCprInfo` final_cpr + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr `setOccInfo` robust_occ_info `setInlinePragInfo` (inlinePragInfo idinfo) `setUnfoldingInfo` unfold_info @@ -1216,14 +1216,14 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold --------- Strictness ------------ mb_bot_str = exprBotStrictness_maybe orig_rhs - sig = strictnessInfo idinfo + sig = dmdSigInfo idinfo final_sig | not $ isTopSig sig = WARN( _bottom_hidden sig , ppr name ) sig -- try a cheap-and-cheerful bottom analyser | Just (_, nsig) <- mb_bot_str = nsig | otherwise = sig - cpr = cprInfo idinfo + cpr = cprSigInfo idinfo final_cpr | Just _ <- mb_bot_str = mkCprSig arity botCpr | otherwise diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index cf0584615b..b3644633af 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1637,8 +1637,8 @@ tcIdInfo ignore_prags toplvl name ty info = do tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = return (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) - tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr) + tcPrag info (HsDmdSig str) = return (info `setDmdSigInfo` str) + tcPrag info (HsCprSig cpr) = return (info `setCprSigInfo` cpr) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) tcPrag info HsLevity = return (info `setNeverLevPoly` ty) tcPrag info (HsLFInfo lf_info) = do @@ -1700,7 +1700,7 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) } where -- Strictness should occur before unfolding! - strict_sig = strictnessInfo info + strict_sig = dmdSigInfo info tcUnfolding toplvl name _ _ (IfCompulsory if_expr) = do { mb_expr <- tcPragExpr True toplvl name if_expr diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs index 29b28d23e2..0e12765314 100644 --- a/compiler/GHC/Types/Cpr.hs +++ b/compiler/GHC/Types/Cpr.hs @@ -4,7 +4,7 @@ -- | Types for the Constructed Product Result lattice. -- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils" --- are its primary customers via 'GHC.Types.Id.idCprInfo'. +-- are its primary customers via 'GHC.Types.Id.idCprSig'. module GHC.Types.Cpr ( Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr, CprType (..), topCprType, botCprType, flatConCprType, @@ -161,12 +161,12 @@ seqCprTy :: CprType -> () seqCprTy (CprType _ cpr) = seqCpr cpr -- | The arity of the wrapped 'CprType' is the arity at which it is safe --- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand" +-- to unleash. See Note [Understanding DmdType and DmdSig] in "GHC.Types.Demand" newtype CprSig = CprSig { getCprSig :: CprType } deriving (Eq, Binary) -- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in +-- unleashable at that arity. See Note [Understanding DmdType and DmdSig] in -- "GHC.Types.Demand" mkCprSigForArity :: Arity -> CprType -> CprSig mkCprSigForArity arty ty@(CprType n cpr) diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 3d6f315f66..61038d0492 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -58,11 +58,11 @@ module GHC.Types.Demand ( keepAliveDmdType, -- * Demand signatures - StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, - splitStrictSig, strictSigDmdEnv, hasDemandEnvSig, + DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, + splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig, nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd, -- ** Handling arity adjustments - prependArgsStrictSig, etaConvertStrictSig, + prependArgsDmdSig, etaConvertDmdSig, -- * Demand transformers from demand signatures DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, @@ -71,7 +71,7 @@ module GHC.Types.Demand ( TypeShape(..), trimToType, -- * @seq@ing stuff - seqDemand, seqDemandList, seqDmdType, seqStrictSig, + seqDemand, seqDemandList, seqDmdType, seqDmdSig, -- * Zapping usage information zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig @@ -590,9 +590,9 @@ addCaseBndrDmd sd alt_dmds = zipWith plusDmd ds alt_dmds -- fuse ds! where Just ds = viewProd (length alt_dmds) sd -- Guaranteed not to be a call -argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info] -argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args +argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args | unsaturated_call = [] | otherwise = go arg_ds where @@ -1257,8 +1257,8 @@ keepAliveDmdType (DmdType fvs ds res) vars = {- Note [Demand type Divergence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand. -This is described in detail in Note [Understanding DmdType and StrictSig]. +In contrast to DmdSigs, DmdTypes are elicited under a specific incoming demand. +This is described in detail in Note [Understanding DmdType and DmdSig]. Here, we'll focus on what that means for a DmdType's Divergence in a higher-order scenario. @@ -1362,7 +1362,7 @@ However, in fact we store in the Id an extremely emascuated demand transfomer, namely a single DmdType -(Nevertheless we dignify StrictSig as a distinct type.) +(Nevertheless we dignify DmdSig as a distinct type.) This DmdType gives the demands unleashed by the Id when it is applied to as many arguments as are given in by the arg demands in the DmdType. @@ -1376,7 +1376,7 @@ demand on all arguments. Otherwise, the demand is specified by Id's signature. For example, the demand transformer described by the demand signature - StrictSig (DmdType {x -> <1L>} <A><1P(L,L)>) + DmdSig (DmdType {x -> <1L>} <A><1P(L,L)>) says that when the function is applied to two arguments, it unleashes demand 1L on the free var x, A on the first arg, and 1P(L,L) on the second. @@ -1384,7 +1384,7 @@ and 1P(L,L) on the second. If this same function is applied to one arg, all we can say is that it uses x with 1L, and its arg with demand 1P(L,L). -Note [Understanding DmdType and StrictSig] +Note [Understanding DmdType and DmdSig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand types are sound approximations of an expression's semantics relative to the incoming demand we put the expression under. Consider the following @@ -1421,51 +1421,51 @@ being a newtype wrapper around DmdType, it actually encodes two things: met. Here comes the subtle part: The threshold is encoded in the wrapped demand -type's depth! So in mkStrictSigForArity we make sure to trim the list of +type's depth! So in mkDmdSigForArity we make sure to trim the list of argument demands to the given threshold arity. Call sites will make sure that this corresponds to the arity of the call demand that elicited the wrapped demand type. See also Note [What are demand signatures?]. -} -- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe --- to unleash. Better construct this through 'mkStrictSigForArity'. --- See Note [Understanding DmdType and StrictSig] -newtype StrictSig - = StrictSig DmdType +-- to unleash. Better construct this through 'mkDmdSigForArity'. +-- See Note [Understanding DmdType and DmdSig] +newtype DmdSig + = DmdSig DmdType deriving Eq --- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] -mkStrictSigForArity :: Arity -> DmdType -> StrictSig -mkStrictSigForArity arity dmd_ty@(DmdType fvs args div) - | arity < dmdTypeDepth dmd_ty = StrictSig (DmdType fvs (take arity args) div) - | otherwise = StrictSig (etaExpandDmdType arity dmd_ty) +-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' +-- unleashable at that arity. See Note [Understanding DmdType and DmdSig] +mkDmdSigForArity :: Arity -> DmdType -> DmdSig +mkDmdSigForArity arity dmd_ty@(DmdType fvs args div) + | arity < dmdTypeDepth dmd_ty = DmdSig (DmdType fvs (take arity args) div) + | otherwise = DmdSig (etaExpandDmdType arity dmd_ty) -mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig -mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) +mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig +mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res) -splitStrictSig :: StrictSig -> ([Demand], Divergence) -splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) +splitDmdSig :: DmdSig -> ([Demand], Divergence) +splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res) -strictSigDmdEnv :: StrictSig -> DmdEnv -strictSigDmdEnv (StrictSig (DmdType env _ _)) = env +dmdSigDmdEnv :: DmdSig -> DmdEnv +dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env -hasDemandEnvSig :: StrictSig -> Bool -hasDemandEnvSig = not . isEmptyVarEnv . strictSigDmdEnv +hasDemandEnvSig :: DmdSig -> Bool +hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv -botSig :: StrictSig -botSig = StrictSig botDmdType +botSig :: DmdSig +botSig = DmdSig botDmdType -nopSig :: StrictSig -nopSig = StrictSig nopDmdType +nopSig :: DmdSig +nopSig = DmdSig nopDmdType -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty +isTopSig :: DmdSig -> Bool +isTopSig (DmdSig ty) = isTopDmdType ty -- | True if the signature diverges or throws an exception in a saturated call. -- See Note [Dead ends]. -isDeadEndSig :: StrictSig -> Bool -isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res +isDeadEndSig :: DmdSig -> Bool +isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res -- | Returns true if an application to n args would diverge or throw an -- exception. @@ -1474,27 +1474,27 @@ isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res -- its syntactic arity, we cannot say for sure that it is going to diverge. -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. -appIsDeadEnd :: StrictSig -> Int -> Bool -appIsDeadEnd (StrictSig (DmdType _ ds res)) n +appIsDeadEnd :: DmdSig -> Int -> Bool +appIsDeadEnd (DmdSig (DmdType _ ds res)) n = isDeadEndDiv res && not (lengthExceeds ds n) -prependArgsStrictSig :: Int -> StrictSig -> StrictSig +prependArgsDmdSig :: Int -> DmdSig -> DmdSig -- ^ Add extra ('topDmd') arguments to a strictness signature. --- In contrast to 'etaConvertStrictSig', this /prepends/ additional argument +-- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument -- demands. This is used by FloatOut. -prependArgsStrictSig new_args sig@(StrictSig dmd_ty@(DmdType env dmds res)) +prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res)) | new_args == 0 = sig | isTopDmdType dmd_ty = sig - | new_args < 0 = pprPanic "prependArgsStrictSig: negative new_args" + | new_args < 0 = pprPanic "prependArgsDmdSig: negative new_args" (ppr new_args $$ ppr sig) - | otherwise = StrictSig (DmdType env dmds' res) + | otherwise = DmdSig (DmdType env dmds' res) where dmds' = replicate new_args topDmd ++ dmds -etaConvertStrictSig :: Arity -> StrictSig -> StrictSig +etaConvertDmdSig :: Arity -> DmdSig -> DmdSig -- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to -- the former (when the Simplifier identifies a new join points, for example). --- In contrast to 'prependArgsStrictSig', this /appends/ extra arg demands if +-- In contrast to 'prependArgsDmdSig', this /appends/ extra arg demands if -- necessary. -- This works by looking at the 'DmdType' (which was produced under a call -- demand for the old arity) and trying to transfer as many facts as we can to @@ -1502,9 +1502,9 @@ etaConvertStrictSig :: Arity -> StrictSig -> StrictSig -- An arity increase (resulting in a stronger incoming demand) can retain much -- of the info, while an arity decrease (a weakening of the incoming demand) -- must fall back to a conservative default. -etaConvertStrictSig arity (StrictSig dmd_ty) - | arity < dmdTypeDepth dmd_ty = StrictSig $ decreaseArityDmdType dmd_ty - | otherwise = StrictSig $ etaExpandDmdType arity dmd_ty +etaConvertDmdSig arity (DmdSig dmd_ty) + | arity < dmdTypeDepth dmd_ty = DmdSig $ decreaseArityDmdType dmd_ty + | otherwise = DmdSig $ etaExpandDmdType arity dmd_ty {- ************************************************************************ @@ -1519,16 +1519,16 @@ etaConvertStrictSig arity (StrictSig dmd_ty) -- (i.e. expression, function) uses its arguments and free variables, and -- whether it diverges. -- --- See Note [Understanding DmdType and StrictSig] +-- See Note [Understanding DmdType and DmdSig] -- and Note [What are demand signatures?]. type DmdTransformer = SubDemand -> DmdType --- | Extrapolate a demand signature ('StrictSig') into a 'DmdTransformer'. +-- | Extrapolate a demand signature ('DmdSig') into a 'DmdTransformer'. -- --- Given a function's 'StrictSig' and a 'SubDemand' for the evaluation context, +-- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, -- return how the function evaluates its free variables and arguments. -dmdTransformSig :: StrictSig -> DmdTransformer -dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) sd +dmdTransformSig :: DmdSig -> DmdTransformer +dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty -- see Note [Demands from unsaturated function calls] -- and Note [What are demand signatures?] @@ -1546,10 +1546,10 @@ dmdTransformDataConSig arity sd = case go arity sd of -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated). -dmdTransformDictSelSig :: StrictSig -> DmdTransformer +dmdTransformDictSelSig :: DmdSig -> DmdTransformer -- NB: This currently doesn't handle newtype dictionaries and it's unclear how -- it could without additional parameters. -dmdTransformDictSelSig (StrictSig (DmdType _ [(_ :* sig_sd)] _)) call_sd +dmdTransformDictSelSig (DmdSig (DmdType _ [(_ :* sig_sd)] _)) call_sd | (n, sd') <- peelCallDmd call_sd , Prod sig_ds <- sig_sd = multDmdType n $ @@ -1642,8 +1642,8 @@ it should not fall over. -} -- | Remove the demand environment from the signature. -zapDmdEnvSig :: StrictSig -> StrictSig -zapDmdEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r +zapDmdEnvSig :: DmdSig -> DmdSig +zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand @@ -1663,9 +1663,9 @@ zapUsedOnceDemand = kill_usage $ KillFlags -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness -- signature -zapUsedOnceSig :: StrictSig -> StrictSig -zapUsedOnceSig (StrictSig (DmdType env ds r)) - = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) +zapUsedOnceSig :: DmdSig -> DmdSig +zapUsedOnceSig (DmdSig (DmdType env ds r)) + = DmdSig (DmdType env (map zapUsedOnceDemand ds) r) data KillFlags = KillFlags { kf_abs :: Bool @@ -1740,8 +1740,8 @@ seqDmdType (DmdType env ds res) = seqDmdEnv :: DmdEnv -> () seqDmdEnv env = seqEltsUFM seqDemandList env -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty +seqDmdSig :: DmdSig -> () +seqDmdSig (DmdSig ty) = seqDmdType ty {- ************************************************************************ @@ -1842,8 +1842,8 @@ instance Outputable DmdType where -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty +instance Outputable DmdSig where + ppr (DmdSig ty) = ppr ty instance Outputable TypeShape where ppr TsUnk = text "TsUnk" @@ -1884,9 +1884,9 @@ instance Binary SubDemand where 2 -> Prod <$> get bh _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) -instance Binary StrictSig where - put_ bh (StrictSig aa) = put_ bh aa - get bh = StrictSig <$> get bh +instance Binary DmdSig where + put_ bh (DmdSig aa) = put_ bh aa + get bh = DmdSig <$> get bh instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index d29bf36d15..dbc2bed651 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -56,7 +56,7 @@ module GHC.Types.Id ( setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, zapIdUsedOnceInfo, zapIdTailCallInfo, - zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, + zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding, transferPolyIdInfo, scaleIdBy, scaleVarBy, -- ** Predicates on Ids @@ -111,12 +111,12 @@ module GHC.Types.Id ( setIdLFInfo, setIdDemandInfo, - setIdStrictness, - setIdCprInfo, + setIdDmdSig, + setIdCprSig, idDemandInfo, - idStrictness, - idCprInfo, + idDmdSig, + idCprSig, ) where @@ -178,8 +178,8 @@ infixl 1 `setIdUnfolding`, `idCafInfo`, `setIdDemandInfo`, - `setIdStrictness`, - `setIdCprInfo`, + `setIdDmdSig`, + `setIdCprSig`, `asJoinId`, `asJoinId_maybe` @@ -673,24 +673,24 @@ idFunRepArity x = countFunRepArgs (idArity x) (idType x) -- See Note [Dead ends] in "GHC.Types.Demand". isDeadEndId :: Var -> Bool isDeadEndId v - | isId v = isDeadEndSig (idStrictness v) + | isId v = isDeadEndSig (idDmdSig v) | otherwise = False --- | Accesses the 'Id''s 'strictnessInfo'. -idStrictness :: Id -> StrictSig -idStrictness id = strictnessInfo (idInfo id) +-- | Accesses the 'Id''s 'dmdSigInfo'. +idDmdSig :: Id -> DmdSig +idDmdSig id = dmdSigInfo (idInfo id) -setIdStrictness :: Id -> StrictSig -> Id -setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id +setIdDmdSig :: Id -> DmdSig -> Id +setIdDmdSig id sig = modifyIdInfo (`setDmdSigInfo` sig) id -idCprInfo :: Id -> CprSig -idCprInfo id = cprInfo (idInfo id) +idCprSig :: Id -> CprSig +idCprSig id = cprSigInfo (idInfo id) -setIdCprInfo :: Id -> CprSig -> Id -setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id +setIdCprSig :: Id -> CprSig -> Id +setIdCprSig id sig = modifyIdInfo (\info -> setCprSigInfo info sig) id -zapIdStrictness :: Id -> Id -zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id +zapIdDmdSig :: Id -> Id +zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id -- | This predicate says whether the 'Id' has a strict demand placed on it or -- has a type such that it can always be evaluated strictly (i.e an @@ -998,15 +998,15 @@ transferPolyIdInfo old_id abstract_wrt new_id new_arity = old_arity + arity_increase new_occ_info = zapOccTailCallInfo old_occ_info - old_strictness = strictnessInfo old_info - new_strictness = prependArgsStrictSig arity_increase old_strictness - old_cpr = cprInfo old_info + old_strictness = dmdSigInfo old_info + new_strictness = prependArgsDmdSig arity_increase old_strictness + old_cpr = cprSigInfo old_info transfer new_info = new_info `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag `setOccInfo` new_occ_info - `setStrictnessInfo` new_strictness - `setCprInfo` old_cpr + `setDmdSigInfo` new_strictness + `setCprSigInfo` old_cpr isNeverLevPolyId :: Id -> Bool isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 0ece12cefa..f9a7cacba8 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -42,8 +42,8 @@ module GHC.Types.Id.Info ( callArityInfo, setCallArityInfo, -- ** Demand and strictness Info - strictnessInfo, setStrictnessInfo, - cprInfo, setCprInfo, + dmdSigInfo, setDmdSigInfo, + cprSigInfo, setCprSigInfo, demandInfo, setDemandInfo, pprStrictness, -- ** Unfolding Info @@ -125,8 +125,8 @@ infixl 1 `setRuleInfo`, `setOneShotInfo`, `setOccInfo`, `setCafInfo`, - `setStrictnessInfo`, - `setCprInfo`, + `setDmdSigInfo`, + `setCprSigInfo`, `setDemandInfo`, `setNeverLevPoly`, `setLevityInfoWithType` @@ -263,10 +263,10 @@ data IdInfo -- ^ Any inline pragma attached to the 'Id' occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program - strictnessInfo :: StrictSig, + dmdSigInfo :: DmdSig, -- ^ A strictness signature. Digests how a function uses its arguments -- if applied to at least 'arityInfo' arguments. - cprInfo :: CprSig, + cprSigInfo :: CprSig, -- ^ Information on whether the function will ultimately return a -- freshly allocated constructor. demandInfo :: Demand, @@ -409,11 +409,11 @@ setOneShotInfo info lb = setDemandInfo :: IdInfo -> Demand -> IdInfo setDemandInfo info dd = dd `seq` info { demandInfo = dd } -setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo -setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } +setDmdSigInfo :: IdInfo -> DmdSig -> IdInfo +setDmdSigInfo info dd = dd `seq` info { dmdSigInfo = dd } -setCprInfo :: IdInfo -> CprSig -> IdInfo -setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } +setCprSigInfo :: IdInfo -> CprSig -> IdInfo +setCprSigInfo info cpr = cpr `seq` info { cprSigInfo = cpr } -- | Basic 'IdInfo' that carries no useful information whatsoever vanillaIdInfo :: IdInfo @@ -424,8 +424,8 @@ vanillaIdInfo inlinePragInfo = defaultInlinePragma, occInfo = noOccInfo, demandInfo = topDmd, - strictnessInfo = nopSig, - cprInfo = topCprSig, + dmdSigInfo = nopSig, + cprSigInfo = topCprSig, bitfield = bitfieldSetCafInfo vanillaCafInfo $ bitfieldSetArityInfo unknownArity $ bitfieldSetCallArityInfo unknownArity $ @@ -501,7 +501,7 @@ type InlinePragInfo = InlinePragma ************************************************************************ -} -pprStrictness :: StrictSig -> SDoc +pprStrictness :: DmdSig -> SDoc pprStrictness sig = ppr sig {- @@ -649,14 +649,14 @@ zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) -- | Remove usage environment info from the strictness signature on the 'IdInfo' zapUsageEnvInfo :: IdInfo -> Maybe IdInfo zapUsageEnvInfo info - | hasDemandEnvSig (strictnessInfo info) - = Just (info {strictnessInfo = zapDmdEnvSig (strictnessInfo info)}) + | hasDemandEnvSig (dmdSigInfo info) + = Just (info {dmdSigInfo = zapDmdEnvSig (dmdSigInfo info)}) | otherwise = Nothing zapUsedOnceInfo :: IdInfo -> Maybe IdInfo zapUsedOnceInfo info - = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) + = Just $ info { dmdSigInfo = zapUsedOnceSig (dmdSigInfo info) , demandInfo = zapUsedOnceDemand (demandInfo info) } zapFragileInfo :: IdInfo -> Maybe IdInfo diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 36a2c9d1df..b2f9dc7adf 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -484,8 +484,8 @@ mkDictSelId name clas base_info = noCafIdInfo `setArityInfo` 1 - `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig `setLevityInfoWithType` sel_ty info | new_tycon @@ -515,7 +515,7 @@ mkDictSelId name clas -- It's worth giving one, so that absence info etc is generated -- even if the selector isn't inlined - strict_sig = mkClosedStrictSig [arg_dmd] topDiv + strict_sig = mkClosedDmdSig [arg_dmd] topDiv arg_dmd | new_tycon = evalDmd | otherwise = C_1N :* Prod [ if name == sel_name then evalDmd else absDmd @@ -582,7 +582,7 @@ mkDataConWorkId wkr_name data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo `setArityInfo` wkr_arity - `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) + `setCprSigInfo` mkCprSig wkr_arity (dataConCPR data_con) `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 @@ -710,14 +710,14 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con -- applications are treated as values `setInlinePragInfo` wrap_prag `setUnfoldingInfo` wrap_unf - `setStrictnessInfo` wrap_sig - `setCprInfo` mkCprSig wrap_arity (dataConCPR data_con) + `setDmdSigInfo` wrap_sig + `setCprSigInfo` mkCprSig wrap_arity (dataConCPR data_con) -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane `setLevityInfoWithType` wrap_ty - wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv + wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv wrap_arg_dmds = replicate (length theta) topDmd ++ map mk_dmd arg_ibangs @@ -1322,14 +1322,14 @@ mkPrimOpId prim_op -- PrimOps don't ever construct a product, but we want to preserve bottoms cpr - | isDeadEndDiv (snd (splitStrictSig strict_sig)) = botCpr + | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr | otherwise = topCpr info = noCafIdInfo `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setCprInfo` mkCprSig arity cpr + `setDmdSigInfo` strict_sig + `setCprSigInfo` mkCprSig arity cpr `setInlinePragInfo` neverInlinePragma `setLevityInfoWithType` res_ty -- We give PrimOps a NOINLINE pragma so that we don't @@ -1361,13 +1361,13 @@ mkFCallId dflags uniq fcall ty info = noCafIdInfo `setArityInfo` arity - `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig `setLevityInfoWithType` ty (bndrs, _) = tcSplitPiTys ty arity = count isAnonTyCoBinder bndrs - strict_sig = mkClosedStrictSig (replicate arity topDmd) topDiv + strict_sig = mkClosedDmdSig (replicate arity topDmd) topDiv -- the call does not claim to be strict in its arguments, since they -- may be lifted (foreign import prim) and the called code doesn't -- necessarily force them. See #11076. |