From f64cf134336820cc98fa45578400d9c9606fa8dc Mon Sep 17 00:00:00 2001 From: Joachim Breitner Date: Mon, 9 Dec 2013 14:36:25 +0000 Subject: Rename topDmdType to nopDmdType because topDmdType is ''not'' the top of the lattice, as it puts an implicit absent demand on free variables, but Abs is the bottom of the Usage lattice. Why nopDmdType? Becuase it is the demand of doing nothing: Everything lazy, everything absent, no definite divergence. --- compiler/basicTypes/Demand.lhs | 40 ++++++++++++++++++++++------------------ compiler/basicTypes/Id.lhs | 2 +- compiler/basicTypes/IdInfo.lhs | 2 +- compiler/coreSyn/CoreArity.lhs | 2 +- compiler/iface/MkIface.lhs | 2 +- compiler/main/TidyPgm.lhs | 4 ++-- compiler/stranal/DmdAnal.lhs | 10 ++++++---- 7 files changed, 34 insertions(+), 28 deletions(-) (limited to 'compiler') diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index ff6c59f8ee..6f88efdf48 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -19,7 +19,7 @@ module Demand ( peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, DmdType(..), dmdTypeDepth, lubDmdType, bothDmdEnv, bothDmdType, - topDmdType, botDmdType, mkDmdType, mkTopDmdType, + nopDmdType, botDmdType, mkDmdType, mkTopDmdType, DmdEnv, emptyDmdEnv, @@ -28,8 +28,8 @@ module Demand ( topRes, botRes, cprProdRes, cprSumRes, appIsBottom, isBottomingSig, pprIfaceStrictSig, returnsCPR, returnsCPRProd, returnsCPR_maybe, - StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig, - isTopSig, splitStrictSig, increaseStrictSigArity, + StrictSig(..), mkStrictSig, nopSig, botSig, cprProdSig, + isNopSig, splitStrictSig, increaseStrictSigArity, seqDemand, seqDemandList, seqDmdType, seqStrictSig, @@ -1030,17 +1030,21 @@ instance Outputable DmdType where emptyDmdEnv :: VarEnv Demand emptyDmdEnv = emptyVarEnv -topDmdType, botDmdType :: DmdType -topDmdType = DmdType emptyDmdEnv [] topRes +-- nopDmdType is the demand of doing nothing +-- (lazy, absent, no CPR information, no termination information). +-- Note that it is ''not'' the top of the lattice (which would be "may use everything"), +-- so it is (no longer) called topDmd +nopDmdType, botDmdType :: DmdType +nopDmdType = DmdType emptyDmdEnv [] topRes botDmdType = DmdType emptyDmdEnv [] botRes cprProdDmdType :: DmdType cprProdDmdType = DmdType emptyDmdEnv [] cprProdRes -isTopDmdType :: DmdType -> Bool -isTopDmdType (DmdType env [] res) +isNopDmdType :: DmdType -> Bool +isNopDmdType (DmdType env [] res) | isTopRes res && isEmptyVarEnv env = True -isTopDmdType _ = False +isNopDmdType _ = False mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType mkDmdType fv ds res = DmdType fv ds res @@ -1096,7 +1100,7 @@ useEnv fv = mapVarEnv useDmd fv -- See Note [IO hack in the demand analyser] deferAfterIO :: DmdType -> DmdType deferAfterIO d@(DmdType _ _ res) = - case d `lubDmdType` topDmdType of + case d `lubDmdType` nopDmdType of DmdType fv ds _ -> DmdType fv ds (defer_res res) where defer_res BotCPR = NoCPR @@ -1132,7 +1136,7 @@ toCleanDmd :: (CleanDemand -> e -> (DmdType, e)) -- See Note [Analyzing with lazy demand and lambdas] toCleanDmd anal (JD { strd = s, absd = u }) e = case (s,u) of - (_, Abs) -> mf (const topDmdType) (anal (CD { sd = HeadStr, ud = Used }) e) + (_, Abs) -> mf (const nopDmdType) (anal (CD { sd = HeadStr, ud = Used }) e) -- See Note [Always analyse in virgin pass] (Str s', Use c u') -> mf (deferAndUse False c) (anal (CD { sd = s', ud = u' }) e) @@ -1240,14 +1244,14 @@ increaseStrictSigArity :: Int -> StrictSig -> StrictSig increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty +isNopSig :: StrictSig -> Bool +isNopSig (StrictSig ty) = isNopDmdType ty isBottomingSig :: StrictSig -> Bool isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res -topSig, botSig :: StrictSig -topSig = StrictSig topDmdType +nopSig, botSig :: StrictSig +nopSig = StrictSig nopDmdType botSig = StrictSig botDmdType cprProdSig :: StrictSig @@ -1301,7 +1305,7 @@ dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) go_abs (_:as) (UCall One d') = go_abs as d' go_abs _ _ = False - -- NB: it's important to use deferType, and not just return topDmdType + -- NB: it's important to use deferType, and not just return nopDmdType -- Consider let { f x y = p + x } in f 1 -- The application isn't saturated, but we must nevertheless propagate -- a lazy demand for p! @@ -1319,7 +1323,7 @@ dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) -- Must remember whether it's a product, hence con_res, not TopRes | otherwise -- Not saturated - = topDmdType + = nopDmdType where go_str 0 dmd = Just (splitStrProdDmd arity dmd) go_str n (SCall s') = go_str (n-1) s' @@ -1340,7 +1344,7 @@ dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd , Just jds <- splitProdDmd_maybe dict_dmd = DmdType emptyDmdEnv [mkManyUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes | otherwise - = topDmdType -- See Note [Demand transformer for a dictionary selector] + = nopDmdType -- See Note [Demand transformer for a dictionary selector] where enhance cd old | isAbsDmd old = old | otherwise = mkManyUsedDmd cd @@ -1359,7 +1363,7 @@ For single-method classes, which are represented by newtypes the signature of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. That's fine: if we are doing strictness analysis we are also doing inling, so we'll have inlined 'op' into a cast. So we can bale out in a conservative -way, returning topDmdType. +way, returning nopDmdType. It is (just.. Trac #8329) possible to be running strictness analysis *without* having inlined class ops from single-method classes. Suppose you are using diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index c2e0c2199d..0c66a503b7 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -476,7 +476,7 @@ setIdStrictness :: Id -> StrictSig -> Id setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id zapIdStrictness :: Id -> Id -zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` topSig) id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` 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 diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index a2bdd5ce54..db0b058fc2 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -290,7 +290,7 @@ vanillaIdInfo inlinePragInfo = defaultInlinePragma, occInfo = NoOccInfo, demandInfo = topDmd, - strictnessInfo = topSig + strictnessInfo = nopSig } -- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 2c9a1375fb..ff39cfc9d9 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -730,7 +730,7 @@ arityType env (Cast e co) arityType _ (Var v) | strict_sig <- idStrictness v - , not $ isTopSig strict_sig + , not $ isNopSig strict_sig , (ds, res) <- splitStrictSig strict_sig , let arity = length ds = if isBotRes res then ABot arity diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b7b5448012..9aad5ffea2 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1777,7 +1777,7 @@ 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) + strict_hsinfo | not (isNopSig sig_info) = Just (HsStrictness sig_info) | otherwise = Nothing ------------ Unfolding -------------- diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 2bfcbb7574..91d0035b1b 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -30,7 +30,7 @@ import IdInfo import InstEnv import FamInstEnv import Type ( tidyTopType ) -import Demand ( appIsBottom, isTopSig, isBottomingSig ) +import Demand ( appIsBottom, isNopSig, isBottomingSig ) import BasicTypes import Name hiding (varName) import NameSet @@ -1109,7 +1109,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ mb_bot_str = exprBotStrictness_maybe orig_rhs sig = strictnessInfo idinfo - final_sig | not $ isTopSig sig + final_sig | not $ isNopSig sig = WARN( _bottom_hidden sig , ppr name ) sig -- try a cheap-and-cheerful bottom analyser | Just (_, nsig) <- mb_bot_str = nsig diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index cadc04c315..2b4a6b1f4c 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -124,9 +124,9 @@ dmdAnal :: AnalEnv -- The CleanDemand is always strict and not absent -- See Note [Ensure demand is strict] -dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit) -dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact -dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co) +dmdAnal _ _ (Lit lit) = (nopDmdType, Lit lit) +dmdAnal _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal _ _ (Coercion co) = (nopDmdType, Coercion co) dmdAnal env dmd (Var var) = (dmdTransform env var dmd, Var var) @@ -338,6 +338,8 @@ dmdAnalAlt env dmd (con,bndrs,rhs) final_alt_ty | io_hack_reqd = deferAfterIO alt_ty | otherwise = alt_ty + -- Note [IO hack in the demand analyser] + -- -- There's a hack here for I/O operations. Consider -- case foo x s of { (# s, r #) -> y } -- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O @@ -1069,7 +1071,7 @@ getStrictness :: AnalEnv -> Id -> StrictSig getStrictness env fn | isGlobalId fn = idStrictness fn | Just (sig, _) <- lookupSigEnv env fn = sig - | otherwise = topSig + | otherwise = nopSig addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -- See Note [Initialising strictness] -- cgit v1.2.1