diff options
| author | Sebastian Graf <sebastian.graf@kit.edu> | 2019-01-28 15:49:04 (GMT) |
|---|---|---|
| committer | Sebastian Graf <sebastian.graf@kit.edu> | 2020-02-12 10:00:58 (GMT) |
| commit | 059c3c9d7c84fc37c69e9f414ff736d47081e72c (patch) | |
| tree | da3c17ac002b9c6d31542af78553769fd40d5d65 | |
| parent | f0c0ee7d9a942a19361e72553cd08f42cc12b04a (diff) | |
| download | ghc-059c3c9d7c84fc37c69e9f414ff736d47081e72c.zip ghc-059c3c9d7c84fc37c69e9f414ff736d47081e72c.tar.gz ghc-059c3c9d7c84fc37c69e9f414ff736d47081e72c.tar.bz2 | |
Separate CPR analysis from the Demand analyserwip/sep-cpr
The reasons for that can be found in the wiki:
https://gitlab.haskell.org/ghc/ghc/wikis/nested-cpr/split-off-cpr
We now run CPR after demand analysis (except for after the final demand
analysis run just before code gen). CPR got its own dump flags
(`-ddump-cpr-anal`, `-ddump-cpr-signatures`), but not its own flag to
activate/deactivate. It will run with `-fstrictness`/`-fworker-wrapper`.
As explained on the wiki page, this step is necessary for a sane Nested
CPR analysis. And it has quite positive impact on compiler performance:
Metric Decrease:
T9233
T9675
T9961
T15263
61 files changed, 1454 insertions, 791 deletions
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 65d0da3..d52c664 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -71,6 +71,7 @@ import VarSet import TyCoRep import TyCoTidy ( tidyCo ) import Demand ( isTopSig ) +import Cpr ( topCprSig ) import Data.Maybe ( catMaybes ) @@ -442,7 +443,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo id_info - = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo, inline_hsinfo, unfold_hsinfo, levity_hsinfo] of [] -> NoInfo infos -> HasInfo infos @@ -466,6 +467,10 @@ toIfaceIdInfo id_info strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) | otherwise = Nothing + ------------ CPR -------------- + cpr_info = cprInfo id_info + cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info) + | otherwise = Nothing ------------ Unfolding -------------- unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) loop_breaker = isStrongLoopBreaker (occInfo id_info) diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 9509cfe..4575142 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -49,6 +49,7 @@ import BinFingerprint import CoreSyn( IsOrphan, isOrphan ) import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) ) import Demand +import Cpr import Class import FieldLabel import NameSet @@ -344,6 +345,7 @@ data IfaceIdInfo data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig + | HsCpr CprSig | HsInline InlinePragma | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] @@ -1394,7 +1396,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:" <+> pprIfaceStrictSig str + ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str + ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr ppr HsNoCafRefs = text "HasNoCafRefs" ppr HsLevity = text "Never levity-polymorphic" @@ -2168,6 +2171,7 @@ instance Binary IfaceInfoItem where 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 get bh = do h <- getByte bh case h of @@ -2178,7 +2182,8 @@ instance Binary IfaceInfoItem where return (HsUnfold lb ad) 3 -> liftM HsInline $ get bh 4 -> return HsNoCafRefs - _ -> return HsLevity + 5 -> return HsLevity + _ -> HsCpr <$> get bh instance Binary IfaceUnfolding where put_ bh (IfCoreUnfold s e) = do @@ -2513,6 +2518,7 @@ instance NFData IfaceInfoItem where HsUnfold b unf -> rnf b `seq` rnf unf HsNoCafRefs -> () HsLevity -> () + HsCpr cpr -> cpr `seq` () instance NFData IfaceUnfolding where rnf = \case diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 8da7700..2b1a4b7 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -40,6 +40,7 @@ import IdInfo import InstEnv import Type ( tidyTopType ) import Demand ( appIsBottom, isTopSig, isBottomingSig ) +import Cpr ( mkCprSig, botCpr ) import BasicTypes import Name hiding (varName) import NameSet @@ -1150,6 +1151,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold -- c.f. CoreTidy.tidyLetBndr `setArityInfo` arity `setStrictnessInfo` final_sig + `setCprInfo` final_cpr `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] -- in CoreTidy @@ -1157,6 +1159,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold = vanillaIdInfo `setArityInfo` arity `setStrictnessInfo` final_sig + `setCprInfo` final_cpr `setOccInfo` robust_occ_info `setInlinePragInfo` (inlinePragInfo idinfo) `setUnfoldingInfo` unfold_info @@ -1180,6 +1183,12 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold | Just (_, nsig) <- mb_bot_str = nsig | otherwise = sig + cpr = cprInfo idinfo + final_cpr | Just _ <- mb_bot_str + = mkCprSig arity botCpr + | otherwise + = cpr + _bottom_hidden id_sig = case mb_bot_str of Nothing -> False Just (arity, _) -> not (appIsBottom id_sig arity) diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 5c58ac9..5cd4806 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1475,6 +1475,7 @@ tcIdInfo ignore_prags toplvl name ty info = do 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 (HsInline prag) = return (info `setInlinePragInfo` prag) tcPrag info HsLevity = return (info `setNeverLevPoly` ty) diff --git a/compiler/basicTypes/Cpr.hs b/compiler/basicTypes/Cpr.hs new file mode 100644 index 0000000..a83b16b --- /dev/null +++ b/compiler/basicTypes/Cpr.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +-- | Types for the Constructed Product Result lattice. "CprAnal" and "WwLib" +-- are its primary customers via 'idCprInfo'. +module Cpr ( + CprResult, topCpr, botCpr, conCpr, asConCpr, + CprType (..), topCprType, botCprType, conCprType, + lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy, + CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig + ) where + +import GhcPrelude + +import BasicTypes +import Outputable +import Binary + +-- +-- * CprResult +-- + +-- | The constructed product result lattice. +-- +-- @ +-- NoCPR +-- | +-- ConCPR ConTag +-- | +-- BotCPR +-- @ +data CprResult = NoCPR -- ^ Top of the lattice + | ConCPR !ConTag -- ^ Returns a constructor from a data type + | BotCPR -- ^ Bottom of the lattice + deriving( Eq, Show ) + +lubCpr :: CprResult -> CprResult -> CprResult +lubCpr (ConCPR t1) (ConCPR t2) + | t1 == t2 = ConCPR t1 +lubCpr BotCPR cpr = cpr +lubCpr cpr BotCPR = cpr +lubCpr _ _ = NoCPR + +topCpr :: CprResult +topCpr = NoCPR + +botCpr :: CprResult +botCpr = BotCPR + +conCpr :: ConTag -> CprResult +conCpr = ConCPR + +trimCpr :: CprResult -> CprResult +trimCpr ConCPR{} = NoCPR +trimCpr cpr = cpr + +asConCpr :: CprResult -> Maybe ConTag +asConCpr (ConCPR t) = Just t +asConCpr NoCPR = Nothing +asConCpr BotCPR = Nothing + +-- +-- * CprType +-- + +-- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. +data CprType + = CprType + { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression + -- eats before returning the 'ct_cpr' + , ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to + -- 'ct_arty' arguments + } + +instance Eq CprType where + a == b = ct_cpr a == ct_cpr b + && (ct_arty a == ct_arty b || ct_cpr a == topCpr) + +topCprType :: CprType +topCprType = CprType 0 topCpr + +botCprType :: CprType +botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments + +conCprType :: ConTag -> CprType +conCprType con_tag = CprType 0 (conCpr con_tag) + +lubCprType :: CprType -> CprType -> CprType +lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) + -- The arity of bottom CPR types can be extended arbitrarily. + | cpr1 == botCpr && n1 <= n2 = ty2 + | cpr2 == botCpr && n2 <= n1 = ty1 + -- There might be non-bottom CPR types with mismatching arities. + -- Consider test DmdAnalGADTs. We want to return top in these cases. + | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) + | otherwise = topCprType + +applyCprTy :: CprType -> CprType +applyCprTy (CprType n res) + | n > 0 = CprType (n-1) res + | res == botCpr = botCprType + | otherwise = topCprType + +abstractCprTy :: CprType -> CprType +abstractCprTy (CprType n res) + | res == topCpr = topCprType + | otherwise = CprType (n+1) res + +ensureCprTyArity :: Arity -> CprType -> CprType +ensureCprTyArity n ty@(CprType m _) + | n == m = ty + | otherwise = topCprType + +trimCprTy :: CprType -> CprType +trimCprTy (CprType arty res) = CprType arty (trimCpr res) + +-- | The arity of the wrapped 'CprType' is the arity at which it is safe +-- to unleash. See Note [Understanding DmdType and StrictSig] in 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 +-- Demand +mkCprSigForArity :: Arity -> CprType -> CprSig +mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty) + +topCprSig :: CprSig +topCprSig = CprSig topCprType + +mkCprSig :: Arity -> CprResult -> CprSig +mkCprSig arty cpr = CprSig (CprType arty cpr) + +seqCprSig :: CprSig -> () +seqCprSig sig = sig `seq` () + +instance Outputable CprResult where + ppr NoCPR = empty + ppr (ConCPR n) = char 'm' <> int n + ppr BotCPR = char 'b' + +instance Outputable CprType where + ppr (CprType arty res) = ppr arty <> ppr res + +-- | Only print the CPR result +instance Outputable CprSig where + ppr (CprSig ty) = ppr (ct_cpr ty) + +instance Binary CprResult where + put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n } + put_ bh NoCPR = putByte bh 1 + put_ bh BotCPR = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (ConCPR n) } + 1 -> return NoCPR + _ -> return BotCPR + +instance Binary CprType where + put_ bh (CprType arty cpr) = do + put_ bh arty + put_ bh cpr + get bh = CprType <$> get bh <*> get bh diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index edb9173..3997bfc 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -29,12 +29,8 @@ module Demand ( DmdEnv, emptyDmdEnv, peelFV, findIdDemand, - DmdResult, CPRResult, - isBotRes, isTopRes, - topRes, botRes, cprProdRes, - vanillaCprProdRes, cprSumRes, + Divergence(..), lubDivergence, isBotDiv, isTopDiv, topDiv, botDiv, appIsBottom, isBottomingSig, pprIfaceStrictSig, - trimCPRInfo, returnsCPR_maybe, StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, nopSig, botSig, cprProdSig, isTopSig, hasDemandEnvSig, @@ -146,9 +142,9 @@ Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, Ben opened #11222. Simon made the demand analyser "understand catch" in 9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call its argument strictly, but also swallow any thrown exceptions in -'postProcessDmdResult'. This was realized by extending the 'Str' constructor of +'postProcessDivergence'. This was realized by extending the 'Str' constructor of 'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and -adding a 'ThrowsExn' constructor to the 'Termination' lattice as an element +adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). @@ -900,85 +896,41 @@ splitProdDmd_maybe (JD { sd = s, ud = u }) {- ************************************************************************ * * - Demand results + Termination * * ************************************************************************ - -DmdResult: Dunno CPRResult +Divergence: Dunno / Diverges - -CPRResult: NoCPR - / \ - RetProd RetSum ConTag - - -Product constructors return (Dunno (RetProd rs)) In a fixpoint iteration, start from Diverges -We have lubs, but not glbs; but that is ok. -} ------------------------------------------------------------------------- --- Constructed Product Result ------------------------------------------------------------------------- - -data Termination r +data Divergence = Diverges -- Definitely diverges - | Dunno r -- Might diverge or converge + | Dunno -- Might diverge or converge deriving( Eq, Show ) --- At this point, Termination is just the 'Lifted' lattice over 'r' --- (https://hackage.haskell.org/package/lattices/docs/Algebra-Lattice-Lifted.html) - -type DmdResult = Termination CPRResult - -data CPRResult = NoCPR -- Top of the lattice - | RetProd -- Returns a constructor from a product type - | RetSum ConTag -- Returns a constructor from a data type - deriving( Eq, Show ) - -lubCPR :: CPRResult -> CPRResult -> CPRResult -lubCPR (RetSum t1) (RetSum t2) - | t1 == t2 = RetSum t1 -lubCPR RetProd RetProd = RetProd -lubCPR _ _ = NoCPR - -lubDmdResult :: DmdResult -> DmdResult -> DmdResult -lubDmdResult Diverges r = r -lubDmdResult r Diverges = r -lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2) +lubDivergence :: Divergence -> Divergence ->Divergence +lubDivergence Diverges r = r +lubDivergence r Diverges = r +lubDivergence Dunno Dunno = Dunno -- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 +-- defaultDmd (r1 `lubDivergence` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 -- (See Note [Default demand on free variables] for why) -bothDmdResult :: DmdResult -> Termination () -> DmdResult --- See Note [Asymmetry of 'both' for DmdType and DmdResult] -bothDmdResult _ Diverges = Diverges -bothDmdResult r (Dunno {}) = r +bothDivergence :: Divergence -> Divergence -> Divergence +-- See Note [Asymmetry of 'both' for DmdType and Divergence] +bothDivergence _ Diverges = Diverges +bothDivergence r Dunno = r -- This needs to commute with defaultDmd, i.e. --- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 +-- defaultDmd (r1 `bothDivergence` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 -- (See Note [Default demand on free variables] for why) -instance Outputable r => Outputable (Termination r) where +instance Outputable Divergence where ppr Diverges = char 'b' - ppr (Dunno c) = ppr c - -instance Outputable CPRResult where - ppr NoCPR = empty - ppr (RetSum n) = char 'm' <> int n - ppr RetProd = char 'm' - -seqDmdResult :: DmdResult -> () -seqDmdResult Diverges = () -seqDmdResult (Dunno c) = seqCPRResult c - -seqCPRResult :: CPRResult -> () -seqCPRResult NoCPR = () -seqCPRResult (RetSum n) = n `seq` () -seqCPRResult RetProd = () - + ppr Dunno = empty ------------------------------------------------------------------------ -- Combined demand result -- @@ -986,64 +938,33 @@ seqCPRResult RetProd = () -- [cprRes] lets us switch off CPR analysis -- by making sure that everything uses TopRes -topRes, botRes :: DmdResult -topRes = Dunno NoCPR -botRes = Diverges +topDiv, botDiv :: Divergence +topDiv = Dunno +botDiv = Diverges -cprSumRes :: ConTag -> DmdResult -cprSumRes tag = Dunno $ RetSum tag - -cprProdRes :: [DmdType] -> DmdResult -cprProdRes _arg_tys = Dunno $ RetProd - -vanillaCprProdRes :: Arity -> DmdResult -vanillaCprProdRes _arity = Dunno $ RetProd - -isTopRes :: DmdResult -> Bool -isTopRes (Dunno NoCPR) = True -isTopRes _ = False +isTopDiv :: Divergence -> Bool +isTopDiv Dunno = True +isTopDiv _ = False -- | True if the result diverges or throws an exception -isBotRes :: DmdResult -> Bool -isBotRes Diverges = True -isBotRes (Dunno {}) = False - -trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult -trimCPRInfo trim_all trim_sums res - = trimR res - where - trimR (Dunno c) = Dunno (trimC c) - trimR res = res - - trimC (RetSum n) | trim_all || trim_sums = NoCPR - | otherwise = RetSum n - trimC RetProd | trim_all = NoCPR - | otherwise = RetProd - trimC NoCPR = NoCPR - -returnsCPR_maybe :: DmdResult -> Maybe ConTag -returnsCPR_maybe (Dunno c) = retCPR_maybe c -returnsCPR_maybe _ = Nothing - -retCPR_maybe :: CPRResult -> Maybe ConTag -retCPR_maybe (RetSum t) = Just t -retCPR_maybe RetProd = Just fIRST_TAG -retCPR_maybe NoCPR = Nothing +isBotDiv :: Divergence -> Bool +isBotDiv Diverges = True +isBotDiv _ = False -- See Notes [Default demand on free variables] -- and [defaultDmd vs. resTypeArgDmd] -defaultDmd :: Termination r -> Demand -defaultDmd (Dunno {}) = absDmd -defaultDmd _ = botDmd -- Diverges +defaultDmd :: Divergence -> Demand +defaultDmd Dunno = absDmd +defaultDmd _ = botDmd -- Diverges -resTypeArgDmd :: Termination r -> Demand +resTypeArgDmd :: Divergence -> Demand -- TopRes and BotRes are polymorphic, so that -- BotRes === (Bot -> BotRes) === ... -- TopRes === (Top -> TopRes) === ... -- This function makes that concrete -- Also see Note [defaultDmd vs. resTypeArgDmd] -resTypeArgDmd (Dunno _) = topDmd -resTypeArgDmd _ = botDmd -- Diverges +resTypeArgDmd Dunno = topDmd +resTypeArgDmd _ = botDmd -- Diverges {- Note [defaultDmd and resTypeArgDmd] @@ -1070,12 +991,12 @@ data DmdType = DmdType DmdEnv -- Demand on explicitly-mentioned -- free variables [Demand] -- Demand on arguments - DmdResult -- See [Nature of result demand] + Divergence -- See [Nature of result demand] {- Note [Nature of result demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A DmdResult contains information about termination (currently distinguishing +A Divergence contains information about termination (currently distinguishing definite divergence and no information; it is possible to include definite convergence here), and CPR information about the result. @@ -1110,10 +1031,10 @@ Now consider a function h with signature "<C(S)>", and the expression now h puts a demand of <C(S)> onto its argument, and the demand transformer turns it into <S>b -Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not +Now the Divergence "b" does apply to us, even though "b1 `seq` ()" does not diverge, and we do not anything being passed to b. -Note [Asymmetry of 'both' for DmdType and DmdResult] +Note [Asymmetry of 'both' for DmdType and Divergence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'both' for DmdTypes is *asymmetrical*, because there is only one result! For example, given (e1 e2), we get a DmdType dt1 for e1, use @@ -1129,21 +1050,21 @@ We 3. combine the termination results, but 4. take CPR info from the first argument. -3 and 4 are implemented in bothDmdResult. +3 and 4 are implemented in bothDivergence. -} -- Equality needed for fixpoints in DmdAnal instance Eq DmdType where - (==) (DmdType fv1 ds1 res1) - (DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 + (==) (DmdType fv1 ds1 div1) + (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 -- It's OK to use nonDetUFMToList here because we're testing for -- equality and even though the lists will be in some arbitrary -- Unique order, it is the same order for both - && ds1 == ds2 && res1 == res2 + && ds1 == ds2 && div1 == div2 lubDmdType :: DmdType -> DmdType -> DmdType lubDmdType d1 d2 - = DmdType lub_fv lub_ds lub_res + = DmdType lub_fv lub_ds lub_div where n = max (dmdTypeDepth d1) (dmdTypeDepth d2) (DmdType fv1 ds1 r1) = ensureArgs n d1 @@ -1151,7 +1072,7 @@ lubDmdType d1 d2 lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_res = lubDmdResult r1 r2 + lub_div = lubDivergence r1 r2 {- Note [The need for BothDmdArg] @@ -1163,25 +1084,25 @@ the demand put on arguments, nor cpr information. So we make that explicit by only passing the relevant information. -} -type BothDmdArg = (DmdEnv, Termination ()) +type BothDmdArg = (DmdEnv, Divergence) mkBothDmdArg :: DmdEnv -> BothDmdArg -mkBothDmdArg env = (env, Dunno ()) +mkBothDmdArg env = (env, Dunno) toBothDmdArg :: DmdType -> BothDmdArg toBothDmdArg (DmdType fv _ r) = (fv, go r) where - go (Dunno {}) = Dunno () - go Diverges = Diverges + go Dunno = Dunno + go Diverges = Diverges bothDmdType :: DmdType -> BothDmdArg -> DmdType bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'both' for DmdType and DmdResult] + -- See Note [Asymmetry of 'both' for DmdType and Divergence] -- 'both' takes the argument/result info from its *first* arg, -- using its second arg just for its free-var info. = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) ds1 - (r1 `bothDmdResult` t2) + (r1 `bothDivergence` t2) instance Outputable DmdType where ppr (DmdType fv ds res) @@ -1202,19 +1123,15 @@ emptyDmdEnv = emptyVarEnv -- 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 :: Arity -> DmdType -cprProdDmdType arity - = DmdType emptyDmdEnv [] (vanillaCprProdRes arity) +nopDmdType = DmdType emptyDmdEnv [] topDiv +botDmdType = DmdType emptyDmdEnv [] botDiv isTopDmdType :: DmdType -> Bool isTopDmdType (DmdType env [] res) - | isTopRes res && isEmptyVarEnv env = True + | isTopDiv res && isEmptyVarEnv env = True isTopDmdType _ = False -mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType +mkDmdType :: DmdEnv -> [Demand] -> Divergence -> DmdType mkDmdType fv ds res = DmdType fv ds res dmdTypeDepth :: DmdType -> Arity @@ -1222,7 +1139,7 @@ dmdTypeDepth (DmdType _ ds _) = length ds -- | This makes sure we can use the demand type with n arguments. -- It extends the argument list with the correct resTypeArgDmd. --- It also adjusts the DmdResult: Divergence survives additional arguments, +-- It also adjusts the Divergence: Divergence survives additional arguments, -- CPR information does not (and definite converge also would not). ensureArgs :: Arity -> DmdType -> DmdType ensureArgs n d | n == depth = d @@ -1232,13 +1149,13 @@ ensureArgs n d | n == depth = d ds' = take n (ds ++ repeat (resTypeArgDmd r)) r' = case r of -- See [Nature of result demand] - Dunno _ -> topRes - _ -> r + Dunno -> topDiv + _ -> r seqDmdType :: DmdType -> () seqDmdType (DmdType env ds res) = - seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` () + seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () seqDmdEnv :: DmdEnv -> () seqDmdEnv env = seqEltsUFM seqDemandList env @@ -1264,7 +1181,7 @@ deferAfterIO d@(DmdType _ _ res) = DmdType fv ds _ -> DmdType fv ds (defer_res res) where defer_res r@(Dunno {}) = r - defer_res _ = topRes -- Diverges + defer_res _ = topDiv -- Diverges strictenDmd :: Demand -> CleanDemand strictenDmd (JD { sd = s, ud = u}) @@ -1302,15 +1219,11 @@ toCleanDmd (JD { sd = s, ud = u }) -- see Note [The need for BothDmdArg] postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) - = (postProcessDmdEnv du fv, term_info) - where - term_info = case postProcessDmdResult ss res_ty of - Dunno _ -> Dunno () - Diverges -> Diverges + = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) -postProcessDmdResult :: Str () -> DmdResult -> DmdResult -postProcessDmdResult Lazy _ = topRes -postProcessDmdResult _ res = res +postProcessDivergence :: Str () -> Divergence -> Divergence +postProcessDivergence Lazy _ = topDiv +postProcessDivergence _ res = res postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env @@ -1333,7 +1246,7 @@ postProcessUnsat :: DmdShell -> DmdType -> DmdType postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) = DmdType (postProcessDmdEnv ds fv) (map (postProcessDmd ds) args) - (postProcessDmdResult ss res_ty) + (postProcessDivergence ss res_ty) postProcessDmd :: DmdShell -> Demand -> Demand postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) @@ -1451,7 +1364,7 @@ its demand is taken to be a result demand of the type. For the usage component, we use Absent. So we use either absDmd or botDmd. -Also note the equations for lubDmdResult (resp. bothDmdResult) noted there. +Also note the equations for lubDivergence (resp. bothDivergence) noted there. Note [Always analyse in virgin pass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1559,7 +1472,7 @@ transfomer, namely 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. -Also see Note [Nature of result demand] for the meaning of a DmdResult in a +Also see Note [Nature of result demand] for the meaning of a Divergence in a strictness signature. If an Id is applied to less arguments than its arity, it means that @@ -1593,7 +1506,7 @@ yields a more precise demand type: ---------------------------------------------------- <S ,HU > | <L,U><L,U>{} <C(C(S )),C1(C1(U ))> | <S,U><L,U>{} - <C(C(S(S,L))),C1(C1(U(1*U,A)))> | <S,1*HU><S,1*U>{} + <C(C(S(S,L))),C1(C1(U(1*U,A)))> | <S,1*HU><L,A>{} Note that in the first example, the depth of the demand type was *higher* than the arity of the incoming call demand due to the anonymous lambda. @@ -1642,10 +1555,10 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) mkStrictSigForArity :: Arity -> DmdType -> StrictSig mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty) -mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig +mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res) -splitStrictSig :: StrictSig -> ([Demand], DmdResult) +splitStrictSig :: StrictSig -> ([Demand], Divergence) splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) increaseStrictSigArity :: Int -> StrictSig -> StrictSig @@ -1686,14 +1599,14 @@ strictSigDmdEnv (StrictSig (DmdType env _ _)) = env -- | True if the signature diverges or throws an exception isBottomingSig :: StrictSig -> Bool -isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res +isBottomingSig (StrictSig (DmdType _ _ res)) = isBotDiv res nopSig, botSig :: StrictSig nopSig = StrictSig nopDmdType botSig = StrictSig botDmdType cprProdSig :: Arity -> StrictSig -cprProdSig arity = StrictSig (cprProdDmdType arity) +cprProdSig _arity = nopSig seqStrictSig :: StrictSig -> () seqStrictSig (StrictSig ty) = seqDmdType ty @@ -1739,7 +1652,7 @@ dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd | (cd',defer_use) <- peelCallDmd cd , Just jds <- splitProdDmd_maybe dict_dmd = postProcessUnsat defer_use $ - DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes + DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where @@ -1829,7 +1742,7 @@ binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. -- See Note [Unsaturated applications] appIsBottom :: StrictSig -> Int -> Bool appIsBottom (StrictSig (DmdType _ ds res)) n - | isBotRes res = not $ lengthExceeds ds n + | isBotDiv res = not $ lengthExceeds ds n appIsBottom _ _ = False {- @@ -2082,23 +1995,11 @@ instance Binary DmdType where dr <- get bh return (DmdType emptyDmdEnv ds dr) -instance Binary DmdResult where - put_ bh (Dunno c) = do { putByte bh 0; put_ bh c } - put_ bh Diverges = putByte bh 1 +instance Binary Divergence where + put_ bh Dunno = putByte bh 0 + put_ bh Diverges = putByte bh 1 get bh = do { h <- getByte bh ; case h of - 0 -> do { c <- get bh; return (Dunno c) } + 0 -> return Dunno _ -> return Diverges } - -instance Binary CPRResult where - put_ bh (RetSum n) = do { putByte bh 0; put_ bh n } - put_ bh RetProd = putByte bh 1 - put_ bh NoCPR = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; return (RetSum n) } - 1 -> return RetProd - _ -> return NoCPR diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index adf775b..9efc512 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -107,9 +107,11 @@ module Id ( setIdDemandInfo, setIdStrictness, + setIdCprInfo, idDemandInfo, idStrictness, + idCprInfo, ) where @@ -137,6 +139,7 @@ import GHC.Types.RepType import TysPrim import DataCon import Demand +import Cpr import Name import Module import Class @@ -164,6 +167,7 @@ infixl 1 `setIdUnfolding`, `setIdDemandInfo`, `setIdStrictness`, + `setIdCprInfo`, `asJoinId`, `asJoinId_maybe` @@ -645,6 +649,12 @@ idStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictSig -> Id setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id +idCprInfo :: Id -> CprSig +idCprInfo id = cprInfo (idInfo id) + +setIdCprInfo :: Id -> CprSig -> Id +setIdCprInfo id sig = modifyIdInfo (\info -> setCprInfo info sig) id + zapIdStrictness :: Id -> Id zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id @@ -948,11 +958,13 @@ transferPolyIdInfo old_id abstract_wrt new_id old_strictness = strictnessInfo old_info new_strictness = increaseStrictSigArity arity_increase old_strictness + old_cpr = cprInfo old_info transfer new_info = new_info `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag `setOccInfo` new_occ_info `setStrictnessInfo` new_strictness + `setCprInfo` old_cpr isNeverLevPolyId :: Id -> Bool isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index b768a0c..d3c5abd 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -42,6 +42,7 @@ module IdInfo ( -- ** Demand and strictness Info strictnessInfo, setStrictnessInfo, + cprInfo, setCprInfo, demandInfo, setDemandInfo, pprStrictness, -- ** Unfolding Info @@ -100,6 +101,7 @@ import ForeignCall import Outputable import Module import Demand +import Cpr import Util -- infixl so you can say (id `set` a `set` b) @@ -111,6 +113,7 @@ infixl 1 `setRuleInfo`, `setOccInfo`, `setCafInfo`, `setStrictnessInfo`, + `setCprInfo`, `setDemandInfo`, `setNeverLevPoly`, `setLevityInfoWithType` @@ -258,6 +261,9 @@ data IdInfo strictnessInfo :: StrictSig, -- ^ A strictness signature. Digests how a function uses its arguments -- if applied to at least 'arityInfo' arguments. + cprInfo :: CprSig, + -- ^ Information on whether the function will ultimately return a + -- freshly allocated constructor. demandInfo :: Demand, -- ^ ID demand information callArityInfo :: !ArityInfo, @@ -302,6 +308,9 @@ setDemandInfo info dd = dd `seq` info { demandInfo = dd } setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } +setCprInfo :: IdInfo -> CprSig -> IdInfo +setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } + -- | Basic 'IdInfo' that carries no useful information whatsoever vanillaIdInfo :: IdInfo vanillaIdInfo @@ -315,6 +324,7 @@ vanillaIdInfo occInfo = noOccInfo, demandInfo = topDmd, strictnessInfo = nopSig, + cprInfo = topCprSig, callArityInfo = unknownArity, levityInfo = NoLevityInfo } diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 49e5115..34183cb 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -63,6 +63,7 @@ import DataCon import Id import IdInfo import Demand +import Cpr import CoreSyn import Unique import UniqSupply @@ -411,6 +412,7 @@ mkDictSelId name clas base_info = noCafIdInfo `setArityInfo` 1 `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig `setLevityInfoWithType` sel_ty info | new_tycon @@ -439,7 +441,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] topRes + strict_sig = mkClosedStrictSig [arg_dmd] topDiv arg_dmd | new_tycon = evalDmd | otherwise = mkManyUsedDmd $ mkProdDmd [ if name == sel_name then evalDmd else absDmd @@ -507,6 +509,7 @@ mkDataConWorkId wkr_name data_con alg_wkr_info = noCafIdInfo `setArityInfo` wkr_arity `setStrictnessInfo` wkr_sig + `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 `setLevityInfoWithType` wkr_ty @@ -514,7 +517,7 @@ mkDataConWorkId wkr_name data_con -- setNeverLevPoly wkr_arity = dataConRepArity data_con - wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) + wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) topDiv -- Note [Data-con worker strictness] -- Notice that we do *not* say the worker Id is strict -- even if the data constructor is declared strict @@ -552,19 +555,17 @@ mkDataConWorkId wkr_name data_con mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) -dataConCPR :: DataCon -> DmdResult +dataConCPR :: DataCon -> CprResult dataConCPR con | isDataTyCon tycon -- Real data types only; that is, -- not unboxed tuples or newtypes , null (dataConExTyCoVars con) -- No existentials , wkr_arity > 0 , wkr_arity <= mAX_CPR_SIZE - = if is_prod then vanillaCprProdRes (dataConRepArity con) - else cprSumRes (dataConTag con) + = conCpr (dataConTag con) | otherwise - = topRes + = topCpr where - is_prod = isProductTyCon tycon tycon = dataConTyCon con wkr_arity = dataConRepArity con @@ -651,12 +652,13 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con `setInlinePragInfo` wrap_prag `setUnfoldingInfo` wrap_unf `setStrictnessInfo` wrap_sig + `setCprInfo` 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 (dataConCPR data_con) + wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv wrap_arg_dmds = replicate (length theta) topDmd ++ map mk_dmd arg_ibangs @@ -1218,10 +1220,16 @@ mkPrimOpId prim_op (AnId id) UserSyntax id = mkGlobalId (PrimOpId prim_op) name ty info + -- PrimOps don't ever construct a product, but we want to preserve bottoms + cpr + | isBotDiv (snd (splitStrictSig strict_sig)) = botCpr + | otherwise = topCpr + info = noCafIdInfo `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) `setArityInfo` arity `setStrictnessInfo` strict_sig + `setCprInfo` mkCprSig arity cpr `setInlinePragInfo` neverInlinePragma `setLevityInfoWithType` res_ty -- We give PrimOps a NOINLINE pragma so that we don't @@ -1254,11 +1262,12 @@ mkFCallId dflags uniq fcall ty info = noCafIdInfo `setArityInfo` arity `setStrictnessInfo` strict_sig + `setCprInfo` topCprSig `setLevityInfoWithType` ty (bndrs, _) = tcSplitPiTys ty arity = count isAnonTyCoBinder bndrs - strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes + strict_sig = mkClosedStrictSig (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. diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index 3c5d2e9..79ac624 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -155,7 +155,7 @@ exprBotStrictness_maybe e Just ar -> Just (ar, sig ar) where env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } - sig ar = mkClosedStrictSig (replicate ar topDmd) botRes + sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv {- Note [exprArity invariant] @@ -758,7 +758,7 @@ arityType _ (Var v) , not $ isTopSig strict_sig , (ds, res) <- splitStrictSig strict_sig , let arity = length ds - = if isBotRes res then ABot arity + = if isBotDiv res then ABot arity else ATop (take arity one_shots) | otherwise = ATop (take (idArity v) one_shots) diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 21f4fd5..c81d754 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -64,7 +64,7 @@ import Util import InstEnv ( instanceDFunId ) import OptCoercion ( checkAxInstCo ) import CoreArity ( typeArity ) -import Demand ( splitStrictSig, isBotRes ) +import Demand ( splitStrictSig, isBotDiv ) import HscTypes import DynFlags @@ -291,7 +291,8 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify -coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal +coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal +coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec @@ -607,7 +608,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ppr binder) ; case splitStrictSig (idStrictness binder) of - (demands, result_info) | isBotRes result_info -> + (demands, result_info) | isBotDiv result_info -> checkL (demands `lengthAtLeast` idArity binder) (text "idArity" <+> ppr (idArity binder) <+> text "exceeds arity imposed by the strictness signature" <+> diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs index 7de8923..aa94a24 100644 --- a/compiler/coreSyn/CoreSeq.hs +++ b/compiler/coreSyn/CoreSeq.hs @@ -15,6 +15,7 @@ import GhcPrelude import CoreSyn import IdInfo import Demand( seqDemand, seqStrictSig ) +import Cpr( seqCprSig ) import BasicTypes( seqOccInfo ) import VarSet( seqDVarSet ) import Var( varType, tyVarKind ) @@ -34,6 +35,7 @@ megaSeqIdInfo info seqDemand (demandInfo info) `seq` seqStrictSig (strictnessInfo info) `seq` + seqCprSig (cprInfo info) `seq` seqCaf (cafInfo info) `seq` seqOneShot (oneShotInfo info) `seq` seqOccInfo (occInfo info) diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index e073078..cde9dc0 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -54,7 +54,10 @@ module CoreUtils ( collectMakeStaticArgs, -- * Join points - isJoinBind + isJoinBind, + + -- * Dumping stuff + dumpIdInfoOfProgram ) where #include "HsVersions.h" @@ -2550,3 +2553,12 @@ isJoinBind :: CoreBind -> Bool isJoinBind (NonRec b _) = isJoinId b isJoinBind (Rec ((b, _) : _)) = isJoinId b isJoinBind _ = False + +dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> CoreProgram -> SDoc +dumpIdInfoOfProgram ppr_id_info binds = vcat (map printId ids) + where + ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) + getIds (NonRec i _) = [ i ] + getIds (Rec bs) = map fst bs + printId id | isExportedId id = ppr id <> colon <+> (ppr_id_info (idInfo id)) + | otherwise = empty diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index a261a98..e21d980 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -74,6 +74,7 @@ import TysPrim import DataCon ( DataCon, dataConWorkId ) import IdInfo import Demand +import Cpr import Name hiding ( varName ) import Outputable import FastString @@ -797,7 +798,8 @@ tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName aBSENT_SUM_FIELD_ERROR_ID = mkVanillaGlobalWithInfo absentSumFieldErrorName (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a - (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes + (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv + `setCprInfo` mkCprSig 0 botCpr `setArityInfo` 0 `setCafInfo` NoCafRefs) -- #15038 @@ -812,6 +814,7 @@ mkRuntimeErrorId name = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info where bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + `setCprInfo` mkCprSig 1 botCpr `setArityInfo` 1 -- Make arity and strictness agree @@ -824,7 +827,7 @@ mkRuntimeErrorId name -- any pc_bottoming_Id will itself have CafRefs, which bloats -- SRTs. - strict_sig = mkClosedStrictSig [evalDmd] botRes + strict_sig = mkClosedStrictSig [evalDmd] botDiv runtimeErrorTy :: Type -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index 0bf188e..44d7fac 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -25,6 +25,7 @@ import Var import Id import IdInfo import Demand +import Cpr import DataCon import TyCon import TyCoPpr @@ -477,6 +478,7 @@ ppIdInfo id info , (has_called_arity, text "CallArity=" <> int called_arity) , (has_caf_info, text "Caf=" <> ppr caf_info) , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_cpr_info, text "Cpr=" <> ppr cpr_info) , (has_unf, text "Unf=" <> ppr unf_info) , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) ] -- Inline pragma, occ, demand, one-shot info @@ -499,6 +501,9 @@ ppIdInfo id info str_info = strictnessInfo info has_str_info = not (isTopSig str_info) + cpr_info = cprInfo info + has_cpr_info = cpr_info /= topCprSig + unf_info = unfoldingInfo info has_unf = hasSomeUnfolding unf_info @@ -617,4 +622,3 @@ instance Outputable id => Outputable (Tickish id) where _ -> hcat [text "scc<", ppr cc, char '>'] ppr (SourceNote span _) = hcat [ text "src<", pprUserRealSpan True span, char '>'] - diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 84a9129..75172c3 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -202,6 +202,7 @@ Library DataCon PatSyn Demand + Cpr GHC.Cmm.DebugBlock Exception FieldLabel @@ -468,6 +469,7 @@ Library Specialise CallArity DmdAnal + CprAnal Exitify WorkWrap WwLib diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 2276559..b306a21 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -464,6 +464,8 @@ data DumpFlag | Opt_D_dump_exitify | Opt_D_dump_stranal | Opt_D_dump_str_signatures + | Opt_D_dump_cpranal + | Opt_D_dump_cpr_signatures | Opt_D_dump_tc | Opt_D_dump_tc_ast | Opt_D_dump_types @@ -3430,6 +3432,10 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_stranal) , make_ord_flag defGhcFlag "ddump-str-signatures" (setDumpFlag Opt_D_dump_str_signatures) + , make_ord_flag defGhcFlag "ddump-cpranal" + (setDumpFlag Opt_D_dump_cpranal) + , make_ord_flag defGhcFlag "ddump-cpr-signatures" + (setDumpFlag Opt_D_dump_cpr_signatures) , make_ord_flag defGhcFlag "ddump-tc" (setDumpFlag Opt_D_dump_tc) , make_ord_flag defGhcFlag "ddump-tc-ast" diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index f86a222..7361c4b 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -72,7 +72,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) topRes } + strictness = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topDiv } fixity = Nothing llvm_only = False vector = [] @@ -2584,7 +2584,7 @@ primop CatchOp "catch#" GenPrimOp with strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd , lazyApply2Dmd - , topDmd] topRes } + , topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2593,7 +2593,7 @@ primop RaiseOp "raise#" GenPrimOp b -> o -- NB: the type variable "o" is "a", but with OpenKind with - strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } + strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } out_of_line = True has_side_effects = True -- raise# certainly throws a Haskell exception and hence has_side_effects @@ -2620,7 +2620,7 @@ primop RaiseDivZeroOp "raiseDivZero#" GenPrimOp -- NB: the type variable "o" is "a", but with OpenKind -- See Note [Arithmetic exception primops] with - strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } + strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } out_of_line = True has_side_effects = True @@ -2630,7 +2630,7 @@ primop RaiseUnderflowOp "raiseUnderflow#" GenPrimOp -- NB: the type variable "o" is "a", but with OpenKind -- See Note [Arithmetic exception primops] with - strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } + strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } out_of_line = True has_side_effects = True @@ -2640,7 +2640,7 @@ primop RaiseOverflowOp "raiseOverflow#" GenPrimOp -- NB: the type variable "o" is "a", but with OpenKind -- See Note [Arithmetic exception primops] with - strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } + strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } out_of_line = True has_side_effects = True @@ -2664,7 +2664,7 @@ primop RaiseOverflowOp "raiseOverflow#" GenPrimOp primop RaiseIOOp "raiseIO#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, b #) with - strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes } + strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] botDiv } out_of_line = True has_side_effects = True @@ -2672,7 +2672,7 @@ primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2681,7 +2681,7 @@ primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } out_of_line = True has_side_effects = True @@ -2689,7 +2689,7 @@ primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2710,7 +2710,7 @@ primop AtomicallyOp "atomically#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes } + strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2728,7 +2728,7 @@ primop AtomicallyOp "atomically#" GenPrimOp primop RetryOp "retry#" GenPrimOp State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } + strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv } out_of_line = True has_side_effects = True @@ -2739,7 +2739,7 @@ primop CatchRetryOp "catchRetry#" GenPrimOp with strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd , lazyApply1Dmd - , topDmd ] topRes } + , topDmd ] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2751,7 +2751,7 @@ primop CatchSTMOp "catchSTM#" GenPrimOp with strictness = { \ _arity -> mkClosedStrictSig [ lazyApply1Dmd , lazyApply2Dmd - , topDmd ] topRes } + , topDmd ] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -3276,7 +3276,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] topRes } + strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topDiv } -- See Note [dataToTag# magic] in PrelRules primop TagToEnumOp "tagToEnum#" GenPrimOp @@ -3792,7 +3792,7 @@ primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp a -> State# s -> State# s - with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv } has_side_effects = True ---- @@ -3810,7 +3810,7 @@ primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp a -> State# s -> State# s - with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv } has_side_effects = True ---- @@ -3828,7 +3828,7 @@ primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp a -> State# s -> State# s - with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv } has_side_effects = True ---- @@ -3846,7 +3846,7 @@ primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp a -> State# s -> State# s - with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes } + with strictness = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv } has_side_effects = True ------------------------------------------------------------------------ diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs index 75c55c6..d3709ac 100644 --- a/compiler/simplCore/CallArity.hs +++ b/compiler/simplCore/CallArity.hs @@ -701,7 +701,7 @@ trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] where max_arity_by_type = length (typeArity (idType v)) max_arity_by_strsig - | isBotRes result_info = length demands + | isBotDiv result_info = length demands | otherwise = a (demands, result_info) = splitStrictSig (idStrictness v) diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 672b56e..24567cb 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -107,7 +107,8 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoStaticArgs | CoreDoCallArity | CoreDoExitify - | CoreDoStrictness + | CoreDoDemand + | CoreDoCpr | CoreDoWorkerWrapper | CoreDoSpecialising | CoreDoSpecConstr @@ -134,7 +135,8 @@ instance Outputable CoreToDo where ppr CoreDoStaticArgs = text "Static argument" ppr CoreDoCallArity = text "Called arity analysis" ppr CoreDoExitify = text "Exitification transformation" - ppr CoreDoStrictness = text "Demand analysis" + ppr CoreDoDemand = text "Demand analysis" + ppr CoreDoCpr = text "Constructed Product Result analysis" ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" ppr CoreDoSpecialising = text "Specialise" ppr CoreDoSpecConstr = text "SpecConstr" diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 7cf0b9d..8f70df9 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -88,6 +88,7 @@ import UniqDSet ( getUniqDSet ) import VarEnv import Literal ( litIsTrivial ) import Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity ) +import Cpr ( mkCprSig, botCpr ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) import Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType @@ -983,6 +984,7 @@ annotateBotStr id n_extra mb_str Nothing -> id Just (arity, sig) -> id `setIdArity` (arity + n_extra) `setIdStrictness` (increaseStrictSigArity n_extra sig) + `setIdCprInfo` mkCprSig (arity + n_extra) botCpr notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 026631d..4c7e509 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -45,6 +45,7 @@ import SAT ( doStaticArgs ) import Specialise ( specProgram) import SpecConstr ( specConstrProgram) import DmdAnal ( dmdAnalProgram ) +import CprAnal ( cprAnalProgram ) import CallArity ( callArityAnalProgram ) import Exitify ( exitifyProgram ) import WorkWrap ( wwTopBinds ) @@ -141,7 +142,7 @@ getCoreToDo dflags maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_strictness_before phase - = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness + = runWhen (phase `elem` strictnessBefore dflags) CoreDoDemand base_mode = SimplMode { sm_phase = panic "base_mode" , sm_names = [] @@ -175,14 +176,12 @@ getCoreToDo dflags -- Don't do case-of-case transformations. -- This makes full laziness work better - strictness_pass = if ww_on - then [CoreDoStrictness,CoreDoWorkerWrapper] - else [CoreDoStrictness] + dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreDoDemand,CoreDoCpr] - -- New demand analyser demand_analyser = (CoreDoPasses ( - strictness_pass ++ + dmd_cpr_ww ++ [simpl_phase 0 ["post-worker-wrapper"] max_iter] )) @@ -332,7 +331,7 @@ getCoreToDo dflags simpl_phase 0 ["final"] max_iter, runWhen late_dmd_anal $ CoreDoPasses ( - strictness_pass ++ + dmd_cpr_ww ++ [simpl_phase 0 ["post-late-ww"] max_iter] ), @@ -341,7 +340,7 @@ getCoreToDo dflags -- has run at all. See Note [Final Demand Analyser run] in DmdAnal -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) CoreDoStrictness, + runWhen (strictness || late_dmd_anal) CoreDoDemand, maybe_rule_check (Phase 0) ] @@ -445,9 +444,12 @@ doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} doCorePass CoreDoExitify = {-# SCC "Exitify" #-} doPass exitifyProgram -doCorePass CoreDoStrictness = {-# SCC "NewStranal" #-} +doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-} doPassDFM dmdAnalProgram +doCorePass CoreDoCpr = {-# SCC "CprAnal" #-} + doPassDFM cprAnalProgram + doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} doPassDFU wwTopBinds @@ -1020,6 +1022,7 @@ transferIdInfo exported_id local_id where local_info = idInfo local_id transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + `setCprInfo` cprInfo local_info `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 5c653c7..03c4b8e 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -499,7 +499,7 @@ mkArgInfo env fun rules n_val_args call_cont -- top-level bindings for (say) strings into -- calls to error. But now we are more careful about -- inlining lone variables, so its ok (see SimplUtils.analyseCont) - if isBotRes result_info then + if isBotDiv result_info then map isStrictDmd demands -- Finite => result is bottom else map isStrictDmd demands ++ vanilla_stricts @@ -1575,7 +1575,7 @@ arguments! Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point +Similarly to CPR (see Note [Don't w/w join points for CPR] in WorkWrap), a join point stands well to gain from its outer binding's eta-expansion, and eta-expanding a join point is fraught with issues like how to deal with a cast: diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 01d802c..50d3514 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -35,14 +35,15 @@ import DataCon ( DataCon, dataConWorkId, dataConRepStrictness , StrictnessMark (..) ) import CoreMonad ( Tick(..), SimplMode(..) ) import CoreSyn -import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd ) +import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd + , mkClosedStrictSig, topDmd, botDiv ) +import Cpr ( mkCprSig, botCpr ) import PprCore ( pprCoreExpr ) import CoreUnfold import CoreUtils import CoreOpt ( pushCoTyArg, pushCoValArg , joinPointBinding_maybe, joinPointBindings_maybe ) import Rules ( mkRuleInfo, lookupRule, getRules ) -import Demand ( mkClosedStrictSig, topDmd, botRes ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, RecFlag(..), Arity ) import MonadUtils ( mapAccumLM, liftIO ) @@ -447,6 +448,7 @@ prepareRhs mode top_lvl occ info (Cast rhs co) -- Note [Float coercions] ; return (floats, Cast rhs' co) } where sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setCprInfo` cprInfo info `setDemandInfo` demandInfo info prepareRhs mode top_lvl occ _ rhs0 @@ -731,8 +733,10 @@ addLetBndrInfo new_bndr new_arity is_bot new_unf = info2 -- Bottoming bindings: see Note [Bottoming bindings] - info4 | is_bot = info3 `setStrictnessInfo` - mkClosedStrictSig (replicate new_arity topDmd) botRes + info4 | is_bot = info3 + `setStrictnessInfo` + mkClosedStrictSig (replicate new_arity topDmd) botDiv + `setCprInfo` mkCprSig new_arity botCpr | otherwise = info3 -- Zap call arity info. We have used it by now (via diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 6a69001..d426b3f 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -48,6 +48,7 @@ import DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) , gopt, hasPprDebug ) import Maybes ( orElse, catMaybes, isJust, isNothing ) import Demand +import Cpr import GHC.Serialized ( deserializeWithData ) import Util import Pair @@ -1726,6 +1727,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) (mkLamTypes spec_lam_args body_ty) -- See Note [Transfer strictness] `setIdStrictness` spec_str + `setIdCprInfo` topCprSig `setIdArity` count isId spec_lam_args `asJoinId_maybe` spec_join_arity spec_str = calcSpecStrictness fn spec_lam_args pats @@ -1759,7 +1761,7 @@ calcSpecStrictness :: Id -- The original function -> StrictSig -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats - = mkClosedStrictSig spec_dmds topRes + = mkClosedStrictSig spec_dmds topDiv where spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] StrictSig (DmdType _ dmds _) = idStrictness fn diff --git a/compiler/stranal/CprAnal.hs b/compiler/stranal/CprAnal.hs new file mode 100644 index 0000000..4b9e54c --- /dev/null +++ b/compiler/stranal/CprAnal.hs @@ -0,0 +1,669 @@ +{-# LANGUAGE CPP #-} + +-- | Constructed Product Result analysis. Identifies functions that surely +-- return heap-allocated records on every code path, so that we can eliminate +-- said heap allocation by performing a worker/wrapper split. +-- +-- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/. +-- CPR analysis should happen after strictness analysis. +-- See Note [Phase ordering]. +module CprAnal ( cprAnalProgram ) where + +#include "HsVersions.h" + +import GhcPrelude + +import WwLib ( deepSplitProductType_maybe ) +import DynFlags +import Demand +import Cpr +import CoreSyn +import CoreSeq +import Outputable +import VarEnv +import BasicTypes +import Data.List +import DataCon +import Id +import IdInfo +import CoreUtils ( exprIsHNF, dumpIdInfoOfProgram ) +import TyCon +import Type +import FamInstEnv +import Util +import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) +import Maybes ( isJust, isNothing ) + +{- Note [Constructed Product Result] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The goal of Constructed Product Result analysis is to identify functions that +surely return heap-allocated records on every code path, so that we can +eliminate said heap allocation by performing a worker/wrapper split. + +@swap@ below is such a function: + + swap (a, b) = (b, a) + +A @case@ on an application of @swap@, like +@case swap (10, 42) of (a, b) -> a + b@ could cancel away +(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then +say that @swap@ has the CPR property. + +We can't inline recursive functions, but similar reasoning applies there: + + f x n = case n of + 0 -> (x, 0) + _ -> f (x+1) (n-1) + +Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed +product with the case. So @f@, too, has the CPR property. But we can't really +"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@ +might be too big to inline (or even marked NOINLINE). We still want to exploit +the CPR property, and that is exactly what the worker/wrapper transformation +can do for us: + + $wf x n = case n of + 0 -> case (x, 0) of -> (a, b) -> (# a, b #) + _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #) + f x n = case $wf x n of (# a, b #) -> (a, b) + +where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to: + + $wf x n = case n of + 0 -> (# x, 0 #) + _ -> $wf (x+1) (n-1) + +Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and +eliminate the heap-allocated pair constructor. + +Note [Phase ordering] +~~~~~~~~~~~~~~~~~~~~~ +We need to perform strictness analysis before CPR analysis, because that might +unbox some arguments, in turn leading to more constructed products. +Ideally, we would want the following pipeline: + +1. Strictness +2. worker/wrapper (for strictness) +3. CPR +4. worker/wrapper (for CPR) + +Currently, we omit 2. and anticipate the results of worker/wrapper. +See Note [CPR in a DataAlt case alternative] and Note [CPR for strict binders]. +An additional w/w pass would simplify things, but probably add slight overhead. +So currently we have + +1. Strictness +2. CPR +3. worker/wrapper (for strictness and CPR) +-} + +-- +-- * Analysing programs +-- + +cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram dflags fam_envs binds = do + let env = emptyAnalEnv fam_envs + let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds + dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr + -- See Note [Stamp out space leaks in demand analysis] in DmdAnal + seqBinds binds_plus_cpr `seq` return binds_plus_cpr + +-- Analyse a (group of) top-level binding(s) +cprAnalTopBind :: AnalEnv + -> CoreBind + -> (AnalEnv, CoreBind) +cprAnalTopBind env (NonRec id rhs) + = (extendAnalEnv env id' (idCprInfo id'), NonRec id' rhs') + where + (id', rhs') = cprAnalBind TopLevel env id rhs + +cprAnalTopBind env (Rec pairs) + = (env', Rec pairs') + where + (env', pairs') = cprFix TopLevel env pairs + +-- +-- * Analysing expressions +-- + +-- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from +-- "Constructed Product Result Analysis for Haskell" +cprAnal, cprAnal' + :: AnalEnv + -> CoreExpr -- ^ expression to be denoted by a 'CprType' + -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' + +cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ + cprAnal' env e + +cprAnal' _ (Lit lit) = (topCprType, Lit lit) +cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact +cprAnal' _ (Coercion co) = (topCprType, Coercion co) + +cprAnal' env (Var var) = (cprTransform env var, Var var) + +cprAnal' env (Cast e co) + = (cpr_ty, Cast e' co) + where + (cpr_ty, e') = cprAnal env e + +cprAnal' env (Tick t e) + = (cpr_ty, Tick t e') + where + (cpr_ty, e') = cprAnal env e + +cprAnal' env (App fun (Type ty)) + = (fun_ty, App fun' (Type ty)) + where + (fun_ty, fun') = cprAnal env fun + +cprAnal' env (App fun arg) + = (res_ty, App fun' arg') + where + (fun_ty, fun') = cprAnal env fun + -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be + -- had by looking into the CprType of arg. + (_, arg') = cprAnal env arg + res_ty = applyCprTy fun_ty + +cprAnal' env (Lam var body) + | isTyVar var + , (body_ty, body') <- cprAnal env body + = (body_ty, Lam var body') + | otherwise + = (lam_ty, Lam var body') + where + env' = extendSigsWithLam env var + (body_ty, body') = cprAnal env' body + lam_ty = abstractCprTy body_ty + +cprAnal' env (Case scrut case_bndr ty alts) + = (res_ty, Case scrut' case_bndr ty alts') + where + (_, scrut') = cprAnal env scrut + -- Regardless whether scrut had the CPR property or not, the case binder + -- certainly has it. See 'extendEnvForDataAlt'. + (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts + res_ty = foldl' lubCprType botCprType alt_tys + +cprAnal' env (Let (NonRec id rhs) body) + = (body_ty, Let (NonRec id' rhs') body') + where + (id', rhs') = cprAnalBind NotTopLevel env id rhs + env' = extendAnalEnv env id' (idCprInfo id') + (body_ty, body') = cprAnal env' body + +cprAnal' env (Let (Rec pairs) body) + = body_ty `seq` (body_ty, Let (Rec pairs') body') + where + (env', pairs') = cprFix NotTopLevel env pairs + (body_ty, body') = cprAnal env' body + +cprAnalAlt + :: AnalEnv + -> CoreExpr -- ^ scrutinee + -> Id -- ^ case binder + -> Alt Var -- ^ current alternative + -> (CprType, Alt Var) +cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs) + -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] + = (rhs_ty, (con, bndrs, rhs')) + where + env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs + (rhs_ty, rhs') = cprAnal env_alt rhs +cprAnalAlt env _ _ (con,bndrs,rhs) + = (rhs_ty, (con, bndrs, rhs')) + where + (rhs_ty, rhs') = cprAnal env rhs + +-- +-- * CPR transformer +-- + +cprTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The function + -> CprType -- ^ The demand type of the function +cprTransform env id + = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig]) + sig + where + sig + | isGlobalId id -- imported function or data con worker + = getCprSig (idCprInfo id) + | Just sig <- lookupSigEnv env id -- local let-bound + = getCprSig sig + | otherwise + = topCprType + +-- +-- * Bindings +-- + +-- Recursive bindings +cprFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> [(Id,CoreExpr)] + -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info + +cprFix top_lvl env orig_pairs + = loop 1 initial_pairs + where + bot_sig = mkCprSig 0 botCpr + -- See Note [Initialising strictness] in DmdAnal.hs + initial_pairs | ae_virgin env = [(setIdCprInfo id bot_sig, rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + + -- The fixed-point varies the idCprInfo field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) + loop n pairs + | found_fixpoint = (final_anal_env, pairs') + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs + first_round = n == 1 + pairs' = step first_round pairs + final_anal_env = extendAnalEnvs env (map fst pairs') + + step :: Bool -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] + step first_round pairs = pairs' + where + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = extendAnalEnvs start_env (map fst pairs) + + (_, pairs') = mapAccumL my_downRhs start pairs + + my_downRhs env (id,rhs) + = (env', (id', rhs')) + where + (id', rhs') = cprAnalBind top_lvl env id rhs + env' = extendAnalEnv env id (idCprInfo id') + +-- | Process the RHS of the binding for a sensible arity, add the CPR signature +-- to the Id, and augment the environment with the signature as well. +cprAnalBind + :: TopLevelFlag + -> AnalEnv + -> Id + -> CoreExpr + -> (Id, CoreExpr) +cprAnalBind top_lvl env id rhs + = (id', rhs') + where + (rhs_ty, rhs') = cprAnal env rhs + -- possibly trim thunk CPR info + rhs_ty' + -- See Note [CPR for thunks] + | stays_thunk = trimCprTy rhs_ty + -- See Note [CPR for sum types] + | returns_sum = trimCprTy rhs_ty + | otherwise = rhs_ty + -- See Note [Arity trimming for CPR signatures] + sig = mkCprSigForArity (idArity id) rhs_ty' + id' = setIdCprInfo id sig + + -- See Note [CPR for thunks] + stays_thunk = is_thunk && not_strict + is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + not_strict = not (isStrictDmd (idDemandInfo id)) + -- See Note [CPR for sum types] + (_, ret_ty) = splitPiTys (idType id) + not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) + returns_sum = not (isTopLevel top_lvl) && not_a_prod + +{- Note [Arity trimming for CPR signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although it doesn't affect correctness of the analysis per se, we have to trim +CPR signatures to idArity. Here's what might happen if we don't: + + f x = if expensive + then \y. Box y + else \z. Box z + g a b = f a b + +The two lambdas will have a CPR type of @1m@ (so construct a product after +applied to one argument). Thus, @f@ will have a CPR signature of @2m@ +(constructs a product after applied to two arguments). +But WW will never eta-expand @f@! In this case that would amount to possibly +duplicating @expensive@ work. + +(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see +Note [Don't eta expand in w/w].) + +So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature +from @f@'s, so it *will* be WW'd: + + f x = if expensive + then \y. Box y + else \z. Box z + $wg a b = case f a b of Box x -> x + g a b = Box ($wg a b) + +And the case in @g@ can never cancel away, thus we introduced extra reboxing. +Hence we always trim the CPR signature of a binding to idArity. +-} + +data AnalEnv + = AE + { ae_sigs :: SigEnv + -- ^ Current approximation of signatures for local ids + , ae_virgin :: Bool + -- ^ True only on every first iteration in a fixed-point + -- iteration. See Note [Initialising strictness] in "DmdAnal" + , ae_fam_envs :: FamInstEnvs + -- ^ Needed when expanding type families and synonyms of product types. + } + +type SigEnv = VarEnv CprSig + +instance Outputable AnalEnv where + ppr (AE { ae_sigs = env, ae_virgin = virgin }) + = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr virgin + , text "ae_sigs =" <+> ppr env ]) + +emptyAnalEnv :: FamInstEnvs -> AnalEnv +emptyAnalEnv fam_envs + = AE + { ae_sigs = emptyVarEnv + , ae_virgin = True + , ae_fam_envs = fam_envs + } + +-- | Extend an environment with the strictness IDs attached to the id +extendAnalEnvs :: AnalEnv -> [Id] -> AnalEnv +extendAnalEnvs env ids + = env { ae_sigs = sigs' } + where + sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ] + +extendAnalEnv :: AnalEnv -> Id -> CprSig -> AnalEnv +extendAnalEnv env id sig + = env { ae_sigs = extendVarEnv (ae_sigs env) id sig } + +lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +extendSigsWithLam :: AnalEnv -> Id -> AnalEnv +-- Extend the AnalEnv when we meet a lambda binder +extendSigsWithLam env id + | isId id + , isStrictDmd (idDemandInfo id) -- See Note [CPR for strict binders] + , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id + = extendAnalEnv env id (CprSig (conCprType (dataConTag dc))) + | otherwise + = env + +extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv +-- See Note [CPR in a DataAlt case alternative] +extendEnvForDataAlt env scrut case_bndr dc bndrs + = foldl' do_con_arg env' ids_w_strs + where + env' = extendAnalEnv env case_bndr (CprSig case_bndr_ty) + + ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc + + tycon = dataConTyCon dc + is_product = isJust (isDataProductTyCon_maybe tycon) + is_sum = isJust (isDataSumTyCon_maybe tycon) + case_bndr_ty + | is_product || is_sum = conCprType (dataConTag dc) + -- Any of the constructors had existentials. This is a little too + -- conservative (after all, we only care about the particular data con), + -- but there is no easy way to write is_sum and this won't happen much. + | otherwise = topCprType + + -- We could have much deeper CPR info here with Nested CPR, which could + -- propagate available unboxed things from the scrutinee, getting rid of + -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative]. + -- Giving strict binders the CPR property only makes sense for products, as + -- the arguments in Note [CPR for strict binders] don't apply to sums (yet); + -- we lack WW for strict binders of sum type. + do_con_arg env (id, str) + | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str + , is_var_scrut && is_strict + , let fam_envs = ae_fam_envs env + , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id + = extendAnalEnv env id (CprSig (conCprType (dataConTag dc))) + | otherwise + = env + + is_var_scrut = is_var scrut + is_var (Cast e _) = is_var e + is_var (Var v) = isLocalId v + is_var _ = False + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, to ensure that all expressions have been traversed at least once, and any +unsound CPR annotations have been updated. + +Note [CPR in a DataAlt case alternative] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case alternative, we want to give some of the binders the CPR property. +Specifically + + * The case binder; inside the alternative, the case binder always has + the CPR property, meaning that a case on it will successfully cancel. + Example: + f True x = case x of y { I# x' -> if x' ==# 3 + then y + else I# 8 } + f False x = I# 3 + + By giving 'y' the CPR property, we ensure that 'f' does too, so we get + f b x = case fw b x of { r -> I# r } + fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + fw False x = 3 + + Of course there is the usual risk of re-boxing: we have 'x' available + boxed and unboxed, but we return the unboxed version for the wrapper to + box. If the wrapper doesn't cancel with its caller, we'll end up + re-boxing something that we did have available in boxed form. + + * Any strict binders with product type, can use Note [CPR for strict binders] + to anticipate worker/wrappering for strictness info. + But we can go a little further. Consider + + data T = MkT !Int Int + + f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) + | otherwise = x + + For $wf2 we are going to unbox the MkT *and*, since it is strict, the + first argument of the MkT; see Note [Add demands for strict constructors]. + But then we don't want box it up again when returning it! We want + 'f2' to have the CPR property, so we give 'x' the CPR property. + + * It's a bit delicate because we're brittly anticipating worker/wrapper here. + If the case above is scrutinising something other than an argument the + original function, we really don't have the unboxed version available. E.g + g v = case foo v of + MkT x y | y>0 -> ... + | otherwise -> x + Here we don't have the unboxed 'x' available. Hence the + is_var_scrut test when making use of the strictness annotation. + Slightly ad-hoc, because even if the scrutinee *is* a variable it + might not be a onre of the arguments to the original function, or a + sub-component thereof. But it's simple, and nothing terrible + happens if we get it wrong. e.g. Trac #10694. + +Note [CPR for strict binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a lambda-bound variable is marked demanded with a strict demand, then give it +a CPR signature, anticipating the results of worker/wrapper. Here's a concrete +example ('f1' in test T10482a), assuming h is strict: + + f1 :: Int -> Int + f1 x = case h x of + A -> x + B -> f1 (x-1) + C -> x+1 + +If we notice that 'x' is used strictly, we can give it the CPR +property; and hence f1 gets the CPR property too. It's sound (doesn't +change strictness) to give it the CPR property because by the time 'x' +is returned (case A above), it'll have been evaluated (by the wrapper +of 'h' in the example). + +Moreover, if f itself is strict in x, then we'll pass x unboxed to +f1, and so the boxed version *won't* be available; in that case it's +very helpful to give 'x' the CPR property. + +Note that + + * We only want to do this for something that definitely + has product type, else we may get over-optimistic CPR results + (e.g. from \x -> x!). + + * See Note [CPR examples] + +Note [CPR for sum types] +~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we do not do CPR for let-bindings that + * non-top level + * bind a sum type +Reason: I found that in some benchmarks we were losing let-no-escapes, +which messed it all up. Example + let j = \x. .... + in case y of + True -> j False + False -> j True +If we w/w this we get + let j' = \x. .... + in case y of + True -> case j' False of { (# a #) -> Just a } + False -> case j' True of { (# a #) -> Just a } +Notice that j' is not a let-no-escape any more. + +However this means in turn that the *enclosing* function +may be CPR'd (via the returned Justs). But in the case of +sums, there may be Nothing alternatives; and that messes +up the sum-type CPR. + +Conclusion: only do this for products. It's still not +guaranteed OK for products, but sums definitely lose sometimes. + +Note [CPR for thunks] +~~~~~~~~~~~~~~~~~~~~~ +If the rhs is a thunk, we usually forget the CPR info, because +it is presumably shared (else it would have been inlined, and +so we'd lose sharing if w/w'd it into a function). E.g. + + let r = case expensive of + (a,b) -> (b,a) + in ... + +If we marked r as having the CPR property, then we'd w/w into + + let $wr = \() -> case expensive of + (a,b) -> (# b, a #) + r = case $wr () of + (# b,a #) -> (b,a) + in ... + +But now r is a thunk, which won't be inlined, so we are no further ahead. +But consider + + f x = let r = case expensive of (a,b) -> (b,a) + in if foo r then r else (x,x) + +Does f have the CPR property? Well, no. + +However, if the strictness analyser has figured out (in a previous +iteration) that it's strict, then we DON'T need to forget the CPR info. +Instead we can retain the CPR info and do the thunk-splitting transform +(see WorkWrap.splitThunk). + +This made a big difference to PrelBase.modInt, which had something like + modInt = \ x -> let r = ... -> I# v in + ...body strict in r... +r's RHS isn't a value yet; but modInt returns r in various branches, so +if r doesn't have the CPR property then neither does modInt +Another case I found in practice (in Complex.magnitude), looks like this: + let k = if ... then I# a else I# b + in ... body strict in k .... +(For this example, it doesn't matter whether k is returned as part of +the overall result; but it does matter that k's RHS has the CPR property.) +Left to itself, the simplifier will make a join point thus: + let $j k = ...body strict in k... + if ... then $j (I# a) else $j (I# b) +With thunk-splitting, we get instead + let $j x = let k = I#x in ...body strict in k... + in if ... then $j a else $j b +This is much better; there's a good chance the I# won't get allocated. + +But what about botCpr? Consider + lvl = error "boom" + fac -1 = lvl + fac 0 = 1 + fac n = n * fac (n-1) +fac won't have the CPR property here when we trim every thunk! But the +assumption is that error cases are rarely entered and we are diverging anyway, +so WW doesn't hurt. + +Note [CPR examples] +~~~~~~~~~~~~~~~~~~~~ +Here are some examples (stranal/should_compile/T10482a) of the +usefulness of Note [CPR in a DataAlt case alternative]. The main +point: all of these functions can have the CPR property. + + ------- f1 ----------- + -- x is used strictly by h, so it'll be available + -- unboxed before it is returned in the True branch + + f1 :: Int -> Int + f1 x = case h x x of + True -> x + False -> f1 (x-1) + + + ------- f2 ----------- + -- x is a strict field of MkT2, so we'll pass it unboxed + -- to $wf2, so it's available unboxed. This depends on + -- the case expression analysing (a subcomponent of) one + -- of the original arguments to the function, so it's + -- a bit more delicate. + + data T2 = MkT2 !Int Int + + f2 :: T2 -> Int + f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) + | otherwise = x + + + ------- f3 ----------- + -- h is strict in x, so x will be unboxed before it + -- is rerturned in the otherwise case. + + data T3 = MkT3 Int Int + + f1 :: T3 -> Int + f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) + | otherwise = x + + + ------- f4 ----------- + -- Just like f2, but MkT4 can't unbox its strict + -- argument automatically, as f2 can + + data family Foo a + newtype instance Foo Int = Foo Int + + data T4 a = MkT4 !(Foo a) Int + + f4 :: T4 Int -> Int + f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) + | otherwise = v +-} diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index 2a5eb97..d8341c1 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -16,17 +16,18 @@ module DmdAnal ( dmdAnalProgram ) where import GhcPrelude import DynFlags -import WwLib ( findTypeShape, deepSplitProductType_maybe ) +import WwLib ( findTypeShape ) import Demand -- All of it import CoreSyn import CoreSeq ( seqBinds ) import Outputable import VarEnv import BasicTypes -import Data.List ( mapAccumL, sortBy ) +import Data.List ( mapAccumL ) import DataCon import Id -import CoreUtils ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation ) +import IdInfo +import CoreUtils import TyCon import Type import Coercion ( Coercion, coVarsOfCo ) @@ -36,8 +37,6 @@ import Maybes ( isJust ) import TysWiredIn import TysPrim ( realWorldStatePrimTy ) import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) -import Name ( getName, stableNameCmp ) -import Data.Function ( on ) import UniqSet {- @@ -49,32 +48,22 @@ import UniqSet -} dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -dmdAnalProgram dflags fam_envs binds - = do { - let { binds_plus_dmds = do_prog binds } ; - dumpIfSet_dyn dflags Opt_D_dump_str_signatures - "Strictness signatures" FormatText - (dumpStrSig binds_plus_dmds) ; - -- See Note [Stamp out space leaks in demand analysis] - seqBinds binds_plus_dmds `seq` return binds_plus_dmds - } - where - do_prog :: CoreProgram -> CoreProgram - do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds +dmdAnalProgram dflags fam_envs binds = do + let env = emptyAnalEnv dflags fam_envs + let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds + dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds + -- See Note [Stamp out space leaks in demand analysis] + seqBinds binds_plus_dmds `seq` return binds_plus_dmds -- Analyse a (group of) top-level binding(s) dmdAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind) dmdAnalTopBind env (NonRec id rhs) - = (extendAnalEnv TopLevel env id2 (idStrictness id2), NonRec id2 rhs2) + = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs') where - ( _, _, rhs1) = dmdAnalRhsLetDown TopLevel Nothing env cleanEvalDmd id rhs - ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin env) cleanEvalDmd id rhs1 - -- Do two passes to improve CPR information - -- See Note [CPR for thunks] - -- See Note [Optimistic CPR in the "virgin" case] - -- See Note [Initial CPR for strict binders] + ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs dmdAnalTopBind env (Rec pairs) = (env', Rec pairs') @@ -217,8 +206,7 @@ dmdAnal' env dmd (Lam var body) = let (body_dmd, defer_and_use) = peelCallDmd dmd -- body_dmd: a demand to analyze the body - env' = extendSigsWithLam env var - (body_ty, body') = dmdAnal env' body_dmd body + (body_ty, body') = dmdAnal env body_dmd body (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var in (postProcessUnsat defer_and_use lam_ty, Lam var' body') @@ -229,8 +217,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) , isJust (isDataProductTyCon_maybe tycon) , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon = let - env_w_tc = env { ae_rec_tc = rec_tc' } - env_alt = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs + env_alt = env { ae_rec_tc = rec_tc' } (rhs_ty, rhs') = dmdAnal env_alt dmd rhs (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr @@ -298,7 +285,7 @@ dmdAnal' env dmd (Let (NonRec id rhs) body) dmdAnal' env dmd (Let (NonRec id rhs) body) = (body_ty2, Let (NonRec id2 rhs') body') where - (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env dmd id rhs + (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs env1 = extendAnalEnv NotTopLevel env id1 (idStrictness id1) (body_ty, body') = dmdAnal env1 dmd body (body_ty1, id2) = annotateBndr env body_ty id1 @@ -474,8 +461,8 @@ dmdTransform env var dmd = dmdTransformDictSelSig (idStrictness var) dmd | isGlobalId var -- Imported function - = let res = dmdTransformSig (idStrictness var) dmd in --- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + , let res = dmdTransformSig (idStrictness var) dmd + = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) res | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing @@ -552,7 +539,7 @@ dmdFix top_lvl env let_dmd orig_pairs my_downRhs (env, lazy_fv) (id,rhs) = ((env', lazy_fv'), (id', rhs')) where - (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env let_dmd id rhs + (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 env' = extendAnalEnv top_lvl env id (idStrictness id') @@ -590,14 +577,14 @@ environment, which effectively assigns them 'nopSig' (see "getStrictness") -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalRhsLetDown :: TopLevelFlag - -> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive - -> AnalEnv -> CleanDemand - -> Id -> CoreExpr - -> (DmdEnv, Id, CoreExpr) +dmdAnalRhsLetDown + :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive + -> AnalEnv -> CleanDemand + -> Id -> CoreExpr + -> (DmdEnv, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs +dmdAnalRhsLetDown rec_flag env let_dmd id rhs = (lazy_fv, id', rhs') where rhs_arity = idArity id @@ -611,9 +598,11 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs -- NB: rhs_arity -- See Note [Demand signatures are computed for a threshold demand based on idArity] = mkRhsDmd env rhs_arity rhs - (DmdType rhs_fv rhs_dmds rhs_res, rhs') + (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs - sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res') + -- TODO: Won't the following line unnecessarily trim down arity for join + -- points returning a lambda in a C(S) context? + sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div) id' = set_idStrictness env id sig -- See Note [NOINLINE and strictness] @@ -625,18 +614,7 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 - - rhs_res' = trimCPRInfo trim_all trim_sums rhs_res - trim_all = is_thunk && not_strict - trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types] - - -- See Note [CPR for thunks] is_thunk = not (exprIsHNF rhs) && not (isJoinId id) - not_strict - = isTopLevel top_lvl -- Top level and recursive things don't - || isJust rec_flag -- get their demandInfo set at all - || not (isStrictDmd (idDemandInfo id) || ae_virgin env) - -- See Note [Optimistic CPR in the "virgin" case] -- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for -- unleashing on the given function's @rhs@, by creating a call demand of @@ -911,7 +889,7 @@ a product type. -} unitDmdType :: DmdEnv -> DmdType -unitDmdType dmd_env = DmdType dmd_env [] topRes +unitDmdType dmd_env = DmdType dmd_env [] topDiv coercionDmdEnv :: Coercion -> DmdEnv coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) @@ -1003,119 +981,6 @@ deleteFVs (DmdType fvs dmds res) bndrs = DmdType (delVarEnvList fvs bndrs) dmds res {- -Note [CPR for sum types] -~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we do not do CPR for let-bindings that - * non-top level - * bind a sum type -Reason: I found that in some benchmarks we were losing let-no-escapes, -which messed it all up. Example - let j = \x. .... - in case y of - True -> j False - False -> j True -If we w/w this we get - let j' = \x. .... - in case y of - True -> case j' False of { (# a #) -> Just a } - False -> case j' True of { (# a #) -> Just a } -Notice that j' is not a let-no-escape any more. - -However this means in turn that the *enclosing* function -may be CPR'd (via the returned Justs). But in the case of -sums, there may be Nothing alternatives; and that messes -up the sum-type CPR. - -Conclusion: only do this for products. It's still not -guaranteed OK for products, but sums definitely lose sometimes. - -Note [CPR for thunks] -~~~~~~~~~~~~~~~~~~~~~ -If the rhs is a thunk, we usually forget the CPR info, because -it is presumably shared (else it would have been inlined, and -so we'd lose sharing if w/w'd it into a function). E.g. - - let r = case expensive of - (a,b) -> (b,a) - in ... - -If we marked r as having the CPR property, then we'd w/w into - - let $wr = \() -> case expensive of - (a,b) -> (# b, a #) - r = case $wr () of - (# b,a #) -> (b,a) - in ... - -But now r is a thunk, which won't be inlined, so we are no further ahead. -But consider - - f x = let r = case expensive of (a,b) -> (b,a) - in if foo r then r else (x,x) - -Does f have the CPR property? Well, no. - -However, if the strictness analyser has figured out (in a previous -iteration) that it's strict, then we DON'T need to forget the CPR info. -Instead we can retain the CPR info and do the thunk-splitting transform -(see WorkWrap.splitThunk). - -This made a big difference to PrelBase.modInt, which had something like - modInt = \ x -> let r = ... -> I# v in - ...body strict in r... -r's RHS isn't a value yet; but modInt returns r in various branches, so -if r doesn't have the CPR property then neither does modInt -Another case I found in practice (in Complex.magnitude), looks like this: - let k = if ... then I# a else I# b - in ... body strict in k .... -(For this example, it doesn't matter whether k is returned as part of -the overall result; but it does matter that k's RHS has the CPR property.) -Left to itself, the simplifier will make a join point thus: - let $j k = ...body strict in k... - if ... then $j (I# a) else $j (I# b) -With thunk-splitting, we get instead - let $j x = let k = I#x in ...body strict in k... - in if ... then $j a else $j b -This is much better; there's a good chance the I# won't get allocated. - -The difficulty with this is that we need the strictness type to -look at the body... but we now need the body to calculate the demand -on the variable, so we can decide whether its strictness type should -have a CPR in it or not. Simple solution: - a) use strictness info from the previous iteration - b) make sure we do at least 2 iterations, by doing a second - round for top-level non-recs. Top level recs will get at - least 2 iterations except for totally-bottom functions - which aren't very interesting anyway. - -NB: strictly_demanded is never true of a top-level Id, or of a recursive Id. - -Note [Optimistic CPR in the "virgin" case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand and strictness info are initialized by top elements. However, -this prevents from inferring a CPR property in the first pass of the -analyser, so we keep an explicit flag ae_virgin in the AnalEnv -datatype. - -We can't start with 'not-demanded' (i.e., top) because then consider - f x = let - t = ... I# x - in - if ... then t else I# y else f x' - -In the first iteration we'd have no demand info for x, so assume -not-demanded; then we'd get TopRes for f's CPR info. Next iteration -we'd see that t was demanded, and so give it the CPR property, but by -now f has TopRes, so it will stay TopRes. Instead, by checking the -ae_virgin flag at the first time round, we say 'yes t is demanded' the -first time. - -However, this does mean that for non-recursive bindings we must -iterate twice to be sure of not getting over-optimistic CPR info, -in the case where t turns out to be not-demanded. This is handled -by dmdAnalTopBind. - - Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The strictness analyser used to have a HACK which ensured that NOINLNE @@ -1289,43 +1154,6 @@ lookupSigEnv env id = lookupVarEnv (ae_sigs env) id nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } -extendSigsWithLam :: AnalEnv -> Id -> AnalEnv --- Extend the AnalEnv when we meet a lambda binder -extendSigsWithLam env id - | isId id - , isStrictDmd (idDemandInfo id) || ae_virgin env - -- See Note [Optimistic CPR in the "virgin" case] - -- See Note [Initial CPR for strict binders] - , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id - = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) - - | otherwise - = env - -extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv --- See Note [CPR in a product case alternative] -extendEnvForProdAlt env scrut case_bndr dc bndrs - = foldl' do_con_arg env1 ids_w_strs - where - env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig - - ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc - case_bndr_sig = cprProdSig (dataConRepArity dc) - fam_envs = ae_fam_envs env - - do_con_arg env (id, str) - | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str - , ae_virgin env || (is_var_scrut && is_strict) -- See Note [CPR in a product case alternative] - , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id - = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc)) - | otherwise - = env - - is_var_scrut = is_var scrut - is_var (Cast e _) = is_var e - is_var (Var v) = isLocalId v - is_var _ = False - findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand]) -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs @@ -1367,158 +1195,8 @@ set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id set_idStrictness env id sig = setIdStrictness id (killUsageSig (ae_dflags env) sig) -dumpStrSig :: CoreProgram -> SDoc -dumpStrSig binds = vcat (map printId ids) - where - ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) - getIds (NonRec i _) = [ i ] - getIds (Rec bs) = map fst bs - printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id) - | otherwise = empty - -{- Note [CPR in a product case alternative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case alternative for a product type, we want to give some of the -binders the CPR property. Specifically - - * The case binder; inside the alternative, the case binder always has - the CPR property, meaning that a case on it will successfully cancel. - Example: - f True x = case x of y { I# x' -> if x' ==# 3 - then y - else I# 8 } - f False x = I# 3 - - By giving 'y' the CPR property, we ensure that 'f' does too, so we get - f b x = case fw b x of { r -> I# r } - fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } - fw False x = 3 - - Of course there is the usual risk of re-boxing: we have 'x' available - boxed and unboxed, but we return the unboxed version for the wrapper to - box. If the wrapper doesn't cancel with its caller, we'll end up - re-boxing something that we did have available in boxed form. - - * Any strict binders with product type, can use - Note [Initial CPR for strict binders]. But we can go a little - further. Consider - - data T = MkT !Int Int - - f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) - | otherwise = x - - For $wf2 we are going to unbox the MkT *and*, since it is strict, the - first argument of the MkT; see Note [Add demands for strict constructors] - in WwLib. But then we don't want box it up again when returning it! We want - 'f2' to have the CPR property, so we give 'x' the CPR property. - - * It's a bit delicate because if this case is scrutinising something other - than an argument the original function, we really don't have the unboxed - version available. E.g - g v = case foo v of - MkT x y | y>0 -> ... - | otherwise -> x - Here we don't have the unboxed 'x' available. Hence the - is_var_scrut test when making use of the strictness annotation. - Slightly ad-hoc, because even if the scrutinee *is* a variable it - might not be a onre of the arguments to the original function, or a - sub-component thereof. But it's simple, and nothing terrible - happens if we get it wrong. e.g. #10694. - - -Note [Initial CPR for strict binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CPR is initialized for a lambda binder in an optimistic manner, i.e, -if the binder is used strictly and at least some of its components as -a product are used, which is checked by the value of the absence -demand. - -If the binder is marked demanded with a strict demand, then give it a -CPR signature. Here's a concrete example ('f1' in test T10482a), -assuming h is strict: - - f1 :: Int -> Int - f1 x = case h x of - A -> x - B -> f1 (x-1) - C -> x+1 - -If we notice that 'x' is used strictly, we can give it the CPR -property; and hence f1 gets the CPR property too. It's sound (doesn't -change strictness) to give it the CPR property because by the time 'x' -is returned (case A above), it'll have been evaluated (by the wrapper -of 'h' in the example). - -Moreover, if f itself is strict in x, then we'll pass x unboxed to -f1, and so the boxed version *won't* be available; in that case it's -very helpful to give 'x' the CPR property. - -Note that - - * We only want to do this for something that definitely - has product type, else we may get over-optimistic CPR results - (e.g. from \x -> x!). - - * See Note [CPR examples] - -Note [CPR examples] -~~~~~~~~~~~~~~~~~~~~ -Here are some examples (stranal/should_compile/T10482a) of the -usefulness of Note [CPR in a product case alternative]. The main -point: all of these functions can have the CPR property. - - ------- f1 ----------- - -- x is used strictly by h, so it'll be available - -- unboxed before it is returned in the True branch - - f1 :: Int -> Int - f1 x = case h x x of - True -> x - False -> f1 (x-1) - - - ------- f2 ----------- - -- x is a strict field of MkT2, so we'll pass it unboxed - -- to $wf2, so it's available unboxed. This depends on - -- the case expression analysing (a subcomponent of) one - -- of the original arguments to the function, so it's - -- a bit more delicate. - - data T2 = MkT2 !Int Int - - f2 :: T2 -> Int - f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) - | otherwise = x - - - ------- f3 ----------- - -- h is strict in x, so x will be unboxed before it - -- is rerturned in the otherwise case. - - data T3 = MkT3 Int Int - - f1 :: T3 -> Int - f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) - | otherwise = x - - - ------- f4 ----------- - -- Just like f2, but MkT4 can't unbox its strict - -- argument automatically, as f2 can - - data family Foo a - newtype instance Foo Int = Foo Int - - data T4 a = MkT4 !(Foo a) Int - - f4 :: T4 Int -> Int - f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) - | otherwise = v - - -Note [Initialising strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs index dfeaac0..fafe075 100644 --- a/compiler/stranal/WorkWrap.hs +++ b/compiler/stranal/WorkWrap.hs @@ -22,6 +22,7 @@ import UniqSupply import BasicTypes import DynFlags import Demand +import Cpr import WwLib import Util import Outputable @@ -336,13 +337,13 @@ There is an infelicity though. We may get something like The code for f duplicates that for g, without any real benefit. It won't really be executed, because calls to f will go via the inlining. -Note [Don't CPR join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There's no point in doing CPR on a join point. If the whole function is getting -CPR'd, then the case expression around the worker function will get pushed into -the join point by the simplifier, which will have the same effect that CPR would -have - the result will be returned in an unboxed tuple. +Note [Don't w/w join points for CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no point in exploiting CPR info on a join point. If the whole function +is getting CPR'd, then the case expression around the worker function will get +pushed into the join point by the simplifier, which will have the same effect +that w/w'ing for CPR would have - the result will be returned in an unboxed +tuple. f z = let join j x y = (x+1, y+1) in case z of A -> j 1 2 @@ -362,10 +363,13 @@ have - the result will be returned in an unboxed tuple. in case z of A -> j 1 2 B -> j 2 3 -Doing CPR on a join point would be tricky anyway, as the worker could not be -a join point because it would not be tail-called. However, doing the *argument* -part of W/W still works for join points, since the wrapper body will make a tail -call: +Note that we still want to give @j@ the CPR property, so that @f@ has it. So +CPR *analyse* join points as regular functions, but don't *transform* them. + +Doing W/W for returned products on a join point would be tricky anyway, as the +worker could not be a join point because it would not be tail-called. However, +doing the *argument* part of W/W still works for join points, since the wrapper +body will make a tail call: f z = let join j x y = x + y in ... @@ -459,7 +463,7 @@ tryWW dflags fam_envs is_rec fn_id rhs -- See Note [Don't w/w inline small non-loop-breaker things] | is_fun && is_eta_exp - = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs + = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs | is_thunk -- See Note [Thunk splitting] = splitThunk dflags fam_envs is_rec new_fn_id rhs @@ -469,7 +473,14 @@ tryWW dflags fam_envs is_rec fn_id rhs where fn_info = idInfo fn_id - (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info) + (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) + + cpr_ty = getCprSig (cprInfo 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 CprAnal + cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info + , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) + ct_cpr cpr_ty new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) -- See Note [Zapping DmdEnv after Demand Analyzer] and @@ -553,12 +564,12 @@ See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. --------------------- -splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr +splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr -> UniqSM [(Id, CoreExpr)] -splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs - = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do +splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs + = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do -- The arity should match the signature - stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_res_info + stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info case stuff of Just (work_demands, join_arity, wrap_fn, work_fn) -> do work_uniq <- getUniqueM @@ -579,7 +590,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs work_join_arity | isJoinId fn_id = Just join_arity | otherwise = Nothing -- worker is join point iff wrapper is join point - -- (see Note [Don't CPR join points]) + -- (see Note [Don't w/w join points for CPR]) work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) `setIdOccInfo` occInfo fn_info @@ -593,10 +604,12 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding -- See Note [Worker-wrapper for INLINABLE functions] - `setIdStrictness` mkClosedStrictSig work_demands work_res_info + `setIdStrictness` mkClosedStrictSig 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 + `setIdDemandInfo` worker_demand `setIdArity` work_arity @@ -649,13 +662,16 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs -- The arity is set by the simplifier using exprEtaExpandArity -- So it may be more than the number of top-level-visible lambdas - use_res_info | isJoinId fn_id = topRes -- Note [Don't CPR join points] - | otherwise = res_info - work_res_info | isJoinId fn_id = res_info -- Worker remains CPR-able - | otherwise - = case returnsCPR_maybe res_info of - Just _ -> topRes -- Cpr stuff done by wrapper; kill it here - Nothing -> res_info -- Preserve exception/divergence + -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, + -- see Note [Don't w/w join points for CPR]. + use_cpr_info | isJoinId fn_id = topCpr + | otherwise = cpr + -- Even if we don't w/w join points for CPR, we might still do so for + -- strictness. In which case a join point worker keeps its original CPR + -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker + -- doesn't have the CPR property anymore. + work_cpr_info | isJoinId fn_id = cpr + | otherwise = topCpr {- diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index d235d3c..fd78b56 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -21,6 +21,7 @@ import Id import IdInfo ( JoinArity ) import DataCon import Demand +import Cpr import MkCore ( mkAbsentErrorApp, mkCoreUbxTup , mkCoreApp, mkCoreLet ) import MkId ( voidArgId, voidPrimId ) @@ -126,7 +127,7 @@ mkWwBodies :: DynFlags -- See Note [Freshen WW arguments] -> Id -- The original function -> [Demand] -- Strictness of original function - -> DmdResult -- Info about function result + -> CprResult -- Info about function result -> UniqSM (Maybe WwResult) -- wrap_fn_args E = \x y -> E @@ -140,7 +141,7 @@ mkWwBodies :: DynFlags -- let x = (a,b) in -- E -mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info +mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) -- See Note [Freshen WW arguments] @@ -151,7 +152,7 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info + <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] @@ -993,18 +994,18 @@ left-to-right traversal of the result structure. mkWWcpr :: Bool -> FamInstEnvs -> Type -- function body type - -> DmdResult -- CPR analysis results + -> CprResult -- CPR analysis results -> UniqSM (Bool, -- Is w/w'ing useful? CoreExpr -> CoreExpr, -- New wrapper CoreExpr -> CoreExpr, -- New worker Type) -- Type of worker's body -mkWWcpr opt_CprAnal fam_envs body_ty res +mkWWcpr opt_CprAnal fam_envs body_ty cpr -- CPR explicitly turned off (or in -O0) | not opt_CprAnal = return (False, id, id, body_ty) -- CPR is turned on by default for -O and O2 | otherwise - = case returnsCPR_maybe res of + = case asConCpr cpr of Nothing -> return (False, id, id, body_ty) -- No CPR info Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty -> mkWWcpr_help stuff @@ -1084,6 +1085,9 @@ after all, the analysis is not really wrong), so we simply do nothing here in mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch other cases where something went avoidably wrong. +This warning also triggers for the stream fusion library within `text`. +We can'easily W/W constructed results like `Stream` because we have no simple +way to express existential types in the worker's type signature. Note [Profiling and unpacking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1170,7 +1174,7 @@ mk_absent_let dflags arg = WARN( True, text "No absent value for" <+> ppr arg_ty ) Nothing -- Can happen for 'State#' and things of 'VecRep' where - lifted_arg = arg `setIdStrictness` botSig + lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr -- Note in strictness signature that this is bottoming -- (for the sake of the "empty case scrutinee not known to -- diverge for sure lint" warning) diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst index 8304434..82d10e6 100644 --- a/docs/users_guide/debugging.rst +++ b/docs/users_guide/debugging.rst @@ -338,6 +338,18 @@ subexpression elimination pass. Dump strictness signatures +.. ghc-flag:: -ddump-cpranal + :shortdesc: Dump CPR analysis output + :type: dynamic + + Dump Constructed Product Result analysis output + +.. ghc-flag:: -ddump-cpr-signatures + :shortdesc: Dump CPR signatures + :type: dynamic + + Dump Constructed Product Result signatures + .. ghc-flag:: -ddump-cse :shortdesc: Dump CSE output :type: dynamic diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 1846656..e2c9032 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -7,7 +7,7 @@ Result size of Tidy Core T2431.$WRefl [InlPrag=INLINE[0]] :: forall a. a :~: a [GblId[DataConWrapper], Caf=NoCafRefs, - Str=m, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True) @@ -17,7 +17,7 @@ T2431.$WRefl -- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0} absurd :: forall a. (Int :~: Bool) -> a -[GblId, Arity=1, Str=<L,U>b, Unf=OtherCon []] +[GblId, Arity=1, Str=<L,U>b, Cpr=b, Unf=OtherCon []] absurd = \ (@a) (x :: Int :~: Bool) -> case x of { } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/numeric/should_compile/T14170.stdout b/testsuite/tests/numeric/should_compile/T14170.stdout index 1371831..700e8d8 100644 --- a/testsuite/tests/numeric/should_compile/T14170.stdout +++ b/testsuite/tests/numeric/should_compile/T14170.stdout @@ -13,7 +13,7 @@ NatVal.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] NatVal.$trModule3 = GHC.Types.TrNameS NatVal.$trModule4 @@ -28,7 +28,7 @@ NatVal.$trModule2 = "NatVal"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] NatVal.$trModule1 = GHC.Types.TrNameS NatVal.$trModule2 @@ -36,7 +36,7 @@ NatVal.$trModule1 = GHC.Types.TrNameS NatVal.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} NatVal.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] NatVal.$trModule diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout index f31f5a3..7a5f491 100644 --- a/testsuite/tests/numeric/should_compile/T14465.stdout +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -20,7 +20,7 @@ M.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} M.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] M.$trModule3 = GHC.Types.TrNameS M.$trModule4 @@ -35,7 +35,7 @@ M.$trModule2 = "M"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} M.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] M.$trModule1 = GHC.Types.TrNameS M.$trModule2 @@ -43,7 +43,7 @@ M.$trModule1 = GHC.Types.TrNameS M.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} M.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] M.$trModule = GHC.Types.Module M.$trModule3 M.$trModule1 diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 6cf1040..e9adc6b 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -13,7 +13,7 @@ T7116.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7116.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7116.$trModule3 = GHC.Types.TrNameS T7116.$trModule4 @@ -28,7 +28,7 @@ T7116.$trModule2 = "T7116"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7116.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7116.$trModule1 = GHC.Types.TrNameS T7116.$trModule2 @@ -36,7 +36,7 @@ T7116.$trModule1 = GHC.Types.TrNameS T7116.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T7116.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T7116.$trModule @@ -46,7 +46,8 @@ T7116.$trModule dr :: Double -> Double [GblId, Arity=1, - Str=<S,1*U(U)>m, + Str=<S,1*U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) @@ -62,7 +63,8 @@ dr dl :: Double -> Double [GblId, Arity=1, - Str=<S,1*U(U)>m, + Str=<S,1*U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) @@ -74,7 +76,8 @@ dl = dr fr :: Float -> Float [GblId, Arity=1, - Str=<S,1*U(U)>m, + Str=<S,1*U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) @@ -92,7 +95,8 @@ fr fl :: Float -> Float [GblId, Arity=1, - Str=<S,1*U(U)>m, + Str=<S,1*U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr index 59f38d2..60345a6 100644 --- a/testsuite/tests/simplCore/should_compile/T13143.stderr +++ b/testsuite/tests/simplCore/should_compile/T13143.stderr @@ -7,7 +7,7 @@ Rec { -- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0} T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker] :: forall a. GHC.Prim.Void# -> a -[GblId, Arity=1, Str=<B,A>b, Unf=OtherCon []] +[GblId, Arity=1, Str=<B,A>b, Cpr=b, Unf=OtherCon []] T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.void# end Rec } @@ -16,6 +16,7 @@ f [InlPrag=NOUSERINLINE[0]] :: forall a. Int -> a [GblId, Arity=1, Str=<B,A>b, + Cpr=b, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True) @@ -32,7 +33,7 @@ T13143.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T13143.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T13143.$trModule3 = GHC.Types.TrNameS T13143.$trModule4 @@ -47,7 +48,7 @@ T13143.$trModule2 = "T13143"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T13143.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T13143.$trModule1 = GHC.Types.TrNameS T13143.$trModule2 @@ -55,7 +56,7 @@ T13143.$trModule1 = GHC.Types.TrNameS T13143.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T13143.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T13143.$trModule @@ -63,7 +64,7 @@ T13143.$trModule -- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} lvl :: Int -[GblId, Str=b] +[GblId, Str=b, Cpr=b] lvl = T13143.$wf @Int GHC.Prim.void# Rec { @@ -91,7 +92,8 @@ end Rec } g [InlPrag=NOUSERINLINE[2]] :: Bool -> Bool -> Int -> Int [GblId, Arity=3, - Str=<S,1*U><S,1*U><S,1*U(U)>m, + Str=<S,1*U><S,1*U><S,1*U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/simplCore/should_compile/T13543.stderr b/testsuite/tests/simplCore/should_compile/T13543.stderr index 219f4f4..9981084 100644 --- a/testsuite/tests/simplCore/should_compile/T13543.stderr +++ b/testsuite/tests/simplCore/should_compile/T13543.stderr @@ -1,14 +1,21 @@ ==================== Strictness signatures ==================== -Foo.$trModule: m -Foo.f: <S(S),1*U(1*U)><S,1*U(U)><S,1*U(U)>m -Foo.g: <S(SS),1*U(1*U(U),1*U(U))>m +Foo.$trModule: +Foo.f: <S(S),1*U(1*U)><S,1*U(U)><S,1*U(U)> +Foo.g: <S(SS),1*U(1*U(U),1*U(U))> + + + +==================== Cpr signatures ==================== +Foo.$trModule: m1 +Foo.f: m1 +Foo.g: m1 ==================== Strictness signatures ==================== -Foo.$trModule: m -Foo.f: <S(S),1*U(1*U)><S,1*U(U)><S,1*U(U)>m -Foo.g: <S(SS),1*U(1*U(U),1*U(U))>m +Foo.$trModule: +Foo.f: <S(S),1*U(1*U)><S,1*U(U)><S,1*U(U)> +Foo.g: <S(SS),1*U(1*U(U),1*U(U))> diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index ca21587..1473c0f 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -13,7 +13,7 @@ T3717.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3717.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T3717.$trModule3 = GHC.Types.TrNameS T3717.$trModule4 @@ -28,7 +28,7 @@ T3717.$trModule2 = "T3717"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3717.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T3717.$trModule1 = GHC.Types.TrNameS T3717.$trModule2 @@ -36,7 +36,7 @@ T3717.$trModule1 = GHC.Types.TrNameS T3717.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T3717.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T3717.$trModule @@ -59,7 +59,8 @@ end Rec } foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int [GblId, Arity=1, - Str=<S(S),1*U(1*U)>m, + Str=<S(S),1*U(1*U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index 7ccb3f4..f458042 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -13,7 +13,7 @@ T3772.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3772.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T3772.$trModule3 = GHC.Types.TrNameS T3772.$trModule4 @@ -28,7 +28,7 @@ T3772.$trModule2 = "T3772"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T3772.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T3772.$trModule1 = GHC.Types.TrNameS T3772.$trModule2 @@ -36,7 +36,7 @@ T3772.$trModule1 = GHC.Types.TrNameS T3772.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T3772.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T3772.$trModule diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index 9eb50c4..0ee2f5c 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/testsuite/tests/simplCore/should_compile/T4201.stdout @@ -1,3 +1,3 @@ - {- HasNoCafRefs, Arity: 1, Strictness: <S,1*H>, + {- HasNoCafRefs, Arity: 1, Strictness: <S,1*H>, CPR: m1, Unfolding: InlineRule (0, True, True) bof `cast` (Sym (N:Foo[0]) ->_R <T>_R) -} diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 38777e5..fc7ed19 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -13,7 +13,7 @@ T4908.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4908.$trModule3 :: TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T4908.$trModule3 = GHC.Types.TrNameS T4908.$trModule4 @@ -28,7 +28,7 @@ T4908.$trModule2 = "T4908"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4908.$trModule1 :: TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T4908.$trModule1 = GHC.Types.TrNameS T4908.$trModule2 @@ -36,7 +36,7 @@ T4908.$trModule1 = GHC.Types.TrNameS T4908.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T4908.$trModule :: Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T4908.$trModule diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 534a435..2ac55f4 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -13,7 +13,7 @@ T4930.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4930.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T4930.$trModule3 = GHC.Types.TrNameS T4930.$trModule4 @@ -28,7 +28,7 @@ T4930.$trModule2 = "T4930"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T4930.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T4930.$trModule1 = GHC.Types.TrNameS T4930.$trModule2 @@ -36,7 +36,7 @@ T4930.$trModule1 = GHC.Types.TrNameS T4930.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T4930.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T4930.$trModule @@ -59,7 +59,8 @@ end Rec } foo [InlPrag=NOUSERINLINE[2]] :: Int -> Int [GblId, Arity=1, - Str=<S,1*U(U)>m, + Str=<S,1*U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 687377b..61892a5 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -8,7 +8,8 @@ T7360.$WFoo3 [InlPrag=INLINE[0]] :: Int -> Foo [GblId[DataConWrapper], Arity=1, Caf=NoCafRefs, - Str=<S,U>m3, + Str=<S,U>, + Cpr=m3, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) @@ -33,7 +34,7 @@ T7360.fun5 = fun1 T7360.Foo1 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.fun4 :: Int [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.fun4 = GHC.Types.I# 0# @@ -42,7 +43,8 @@ T7360.fun4 = GHC.Types.I# 0# fun2 :: forall a. [a] -> ((), Int) [GblId, Arity=1, - Str=<L,1*U>m, + Str=<L,1*U>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) @@ -76,7 +78,7 @@ T7360.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.$trModule3 = GHC.Types.TrNameS T7360.$trModule4 @@ -91,7 +93,7 @@ T7360.$trModule2 = "T7360"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.$trModule1 = GHC.Types.TrNameS T7360.$trModule2 @@ -99,7 +101,7 @@ T7360.$trModule1 = GHC.Types.TrNameS T7360.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T7360.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T7360.$trModule @@ -107,7 +109,7 @@ T7360.$trModule -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} $krep :: GHC.Types.KindRep -[GblId, Str=m1, Unf=OtherCon []] +[GblId, Cpr=m1, Unf=OtherCon []] $krep = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) @@ -122,7 +124,7 @@ T7360.$tcFoo2 = "Foo"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2 @@ -130,7 +132,7 @@ T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tcFoo :: GHC.Types.TyCon [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] T7360.$tcFoo @@ -144,7 +146,7 @@ T7360.$tcFoo -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} T7360.$tc'Foo4 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep -[GblId, Str=m1, Unf=OtherCon []] +[GblId, Cpr=m1, Unf=OtherCon []] T7360.$tc'Foo4 = GHC.Types.KindRepTyConApp T7360.$tcFoo (GHC.Types.[] @GHC.Types.KindRep) @@ -159,7 +161,7 @@ T7360.$tc'Foo6 = "'Foo1"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo5 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.$tc'Foo5 = GHC.Types.TrNameS T7360.$tc'Foo6 @@ -167,7 +169,7 @@ T7360.$tc'Foo5 = GHC.Types.TrNameS T7360.$tc'Foo6 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo1 :: GHC.Types.TyCon [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] T7360.$tc'Foo1 @@ -189,7 +191,7 @@ T7360.$tc'Foo8 = "'Foo2"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo7 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.$tc'Foo7 = GHC.Types.TrNameS T7360.$tc'Foo8 @@ -197,7 +199,7 @@ T7360.$tc'Foo7 = GHC.Types.TrNameS T7360.$tc'Foo8 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo2 :: GHC.Types.TyCon [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] T7360.$tc'Foo2 @@ -211,7 +213,7 @@ T7360.$tc'Foo2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo9 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep -[GblId, Str=m4, Unf=OtherCon []] +[GblId, Cpr=m4, Unf=OtherCon []] T7360.$tc'Foo9 = GHC.Types.KindRepFun $krep T7360.$tc'Foo4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} @@ -224,7 +226,7 @@ T7360.$tc'Foo11 = "'Foo3"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo10 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T7360.$tc'Foo10 = GHC.Types.TrNameS T7360.$tc'Foo11 @@ -232,7 +234,7 @@ T7360.$tc'Foo10 = GHC.Types.TrNameS T7360.$tc'Foo11 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T7360.$tc'Foo3 :: GHC.Types.TyCon [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] T7360.$tc'Foo3 diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 7146b76..64a4e6d 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -243,7 +243,7 @@ test('T13410', normal, compile, ['-O2']) test('T13468', normal, makefile_test, ['T13468']) -test('T13543', only_ways(['optasm']), compile, ['-ddump-str-signatures']) +test('T13543', only_ways(['optasm']), compile, ['-ddump-str-signatures -ddump-cpr-signatures']) test('T11272', normal, makefile_test, ['T11272']) diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr index 2b15450..3b5a9c2 100644 --- a/testsuite/tests/simplCore/should_compile/noinline01.stderr +++ b/testsuite/tests/simplCore/should_compile/noinline01.stderr @@ -14,7 +14,7 @@ Noinline01.$trModule4 :: GHC.Prim.Addr# "main"#; Noinline01.$trModule3 :: GHC.Types.TrName -[GblId, Str=m1, Unf=OtherCon []] = +[GblId, Cpr=m1, Unf=OtherCon []] = CCS_DONT_CARE GHC.Types.TrNameS! [Noinline01.$trModule4]; Noinline01.$trModule2 :: GHC.Prim.Addr# @@ -22,11 +22,11 @@ Noinline01.$trModule2 :: GHC.Prim.Addr# "Noinline01"#; Noinline01.$trModule1 :: GHC.Types.TrName -[GblId, Str=m1, Unf=OtherCon []] = +[GblId, Cpr=m1, Unf=OtherCon []] = CCS_DONT_CARE GHC.Types.TrNameS! [Noinline01.$trModule2]; Noinline01.$trModule :: GHC.Types.Module -[GblId, Str=m, Unf=OtherCon []] = +[GblId, Cpr=m1, Unf=OtherCon []] = CCS_DONT_CARE GHC.Types.Module! [Noinline01.$trModule3 Noinline01.$trModule1]; diff --git a/testsuite/tests/simplCore/should_compile/par01.stderr b/testsuite/tests/simplCore/should_compile/par01.stderr index 98de76e..1a8cdfd 100644 --- a/testsuite/tests/simplCore/should_compile/par01.stderr +++ b/testsuite/tests/simplCore/should_compile/par01.stderr @@ -21,7 +21,7 @@ Par01.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Par01.$trModule3 :: GHC.Types.TrName -[GblId, Str=m1, Unf=OtherCon []] +[GblId, Cpr=m1, Unf=OtherCon []] Par01.$trModule3 = GHC.Types.TrNameS Par01.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} @@ -31,12 +31,12 @@ Par01.$trModule2 = "Par01"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Par01.$trModule1 :: GHC.Types.TrName -[GblId, Str=m1, Unf=OtherCon []] +[GblId, Cpr=m1, Unf=OtherCon []] Par01.$trModule1 = GHC.Types.TrNameS Par01.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Par01.$trModule :: GHC.Types.Module -[GblId, Str=m, Unf=OtherCon []] +[GblId, Cpr=m1, Unf=OtherCon []] Par01.$trModule = GHC.Types.Module Par01.$trModule3 Par01.$trModule1 diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 7cfd444..5fdb900 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -13,7 +13,7 @@ Roman.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.$trModule3 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] Roman.$trModule3 = GHC.Types.TrNameS Roman.$trModule4 @@ -28,7 +28,7 @@ Roman.$trModule2 = "Roman"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.$trModule1 :: GHC.Types.TrName [GblId, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] Roman.$trModule1 = GHC.Types.TrNameS Roman.$trModule2 @@ -36,7 +36,7 @@ Roman.$trModule1 = GHC.Types.TrNameS Roman.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} Roman.$trModule :: GHC.Types.Module [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] Roman.$trModule @@ -49,7 +49,7 @@ lvl = "spec-inline.hs:(19,5)-(29,25)|function go"# -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} Roman.foo3 :: Int -[GblId, Str=b] +[GblId, Str=b, Cpr=b] Roman.foo3 = Control.Exception.Base.patError @'GHC.Types.LiftedRep @Int lvl @@ -116,7 +116,8 @@ Roman.foo_go [InlPrag=NOUSERINLINE[2]] :: Maybe Int -> Maybe Int -> Int [GblId, Arity=2, - Str=<S,1*U><S,1*U>m, + Str=<S,1*U><S,1*U>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) @@ -131,7 +132,7 @@ Roman.foo_go -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.foo2 :: Int [GblId, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] Roman.foo2 = GHC.Types.I# 6# @@ -139,7 +140,7 @@ Roman.foo2 = GHC.Types.I# 6# -- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} Roman.foo1 :: Maybe Int [GblId, - Str=m2, + Cpr=m2, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] Roman.foo1 = GHC.Maybe.Just @Int Roman.foo2 @@ -148,7 +149,8 @@ Roman.foo1 = GHC.Maybe.Just @Int Roman.foo2 foo :: Int -> Int [GblId, Arity=1, - Str=<S,1*U(U)>m, + Str=<S,1*U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/stranal/should_compile/T10694.stderr b/testsuite/tests/stranal/should_compile/T10694.stderr index 90ab947..5eb2c18 100644 --- a/testsuite/tests/stranal/should_compile/T10694.stderr +++ b/testsuite/tests/stranal/should_compile/T10694.stderr @@ -6,37 +6,38 @@ Result size of Tidy Core = {terms: 74, types: 65, coercions: 0, joins: 0/4} T10694.$wpm [InlPrag=NOINLINE] :: Int -> Int -> (# Int, Int #) [GblId, Arity=2, Str=<L,U(U)><L,U(U)>, Unf=OtherCon []] T10694.$wpm - = \ (w_s1v7 :: Int) (w1_s1v8 :: Int) -> + = \ (w_s1vj :: Int) (w1_s1vk :: Int) -> let { - l_s1u8 :: Int + l_s1uR :: Int [LclId] - l_s1u8 - = case w_s1v7 of { GHC.Types.I# x_a1ty -> case w1_s1v8 of { GHC.Types.I# y_a1tC -> GHC.Types.I# (GHC.Prim.+# x_a1ty y_a1tC) } } } in + l_s1uR + = case w_s1vj of { GHC.Types.I# x_aJ9 -> case w1_s1vk of { GHC.Types.I# y_aJc -> GHC.Types.I# (GHC.Prim.+# x_aJ9 y_aJc) } } } in let { - l1_s1u9 :: Int + l1_s1uS :: Int [LclId] - l1_s1u9 - = case w_s1v7 of { GHC.Types.I# x_a1tI -> case w1_s1v8 of { GHC.Types.I# y_a1tM -> GHC.Types.I# (GHC.Prim.-# x_a1tI y_a1tM) } } } in + l1_s1uS + = case w_s1vj of { GHC.Types.I# x_aJh -> case w1_s1vk of { GHC.Types.I# y_aJk -> GHC.Types.I# (GHC.Prim.-# x_aJh y_aJk) } } } in let { - l2_s1ua :: [Int] + l2_s1uT :: [Int] [LclId, Unf=OtherCon []] - l2_s1ua = GHC.Types.: @ Int l1_s1u9 (GHC.Types.[] @ Int) } in + l2_s1uT = GHC.Types.: @Int l1_s1uS (GHC.Types.[] @Int) } in let { - l3_s1tZ :: [Int] + l3_sJv :: [Int] [LclId, Unf=OtherCon []] - l3_s1tZ = GHC.Types.: @ Int l_s1u8 l2_s1ua } in - (# GHC.List.$w!! @ Int l3_s1tZ 0#, GHC.List.$w!! @ Int l3_s1tZ 1# #) + l3_sJv = GHC.Types.: @Int l_s1uR l2_s1uT } in + (# GHC.List.$w!! @Int l3_sJv 0#, GHC.List.$w!! @Int l3_sJv 1# #) -- RHS size: {terms: 10, types: 11, coercions: 0, joins: 0/0} pm [InlPrag=NOUSERINLINE[0]] :: Int -> Int -> (Int, Int) [GblId, Arity=2, - Str=<L,U(U)><L,U(U)>m, + Str=<L,U(U)><L,U(U)>, + Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w_s1v7 [Occ=Once] :: Int) (w1_s1v8 [Occ=Once] :: Int) -> - case T10694.$wpm w_s1v7 w1_s1v8 of { (# ww1_s1vd [Occ=Once], ww2_s1ve [Occ=Once] #) -> (ww1_s1vd, ww2_s1ve) }}] -pm = \ (w_s1v7 :: Int) (w1_s1v8 :: Int) -> case T10694.$wpm w_s1v7 w1_s1v8 of { (# ww1_s1vd, ww2_s1ve #) -> (ww1_s1vd, ww2_s1ve) } + Tmpl= \ (w_s1vj [Occ=Once] :: Int) (w1_s1vk [Occ=Once] :: Int) -> + case T10694.$wpm w_s1vj w1_s1vk of { (# ww1_s1vp [Occ=Once], ww2_s1vq [Occ=Once] #) -> (ww1_s1vp, ww2_s1vq) }}] +pm = \ (w_s1vj :: Int) (w1_s1vk :: Int) -> case T10694.$wpm w_s1vj w1_s1vk of { (# ww1_s1vp, ww2_s1vq #) -> (ww1_s1vp, ww2_s1vq) } -- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} m :: Int -> Int -> Int @@ -45,45 +46,38 @@ m :: Int -> Int -> Int Str=<L,U(U)><L,U(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (x_a12s [Occ=Once] :: Int) (y_a12t [Occ=Once] :: Int) -> - case pm x_a12s y_a12t of { (_ [Occ=Dead], mr_a12v [Occ=Once]) -> mr_a12v }}] -m = \ (x_a12s :: Int) (y_a12t :: Int) -> case T10694.$wpm x_a12s y_a12t of { (# ww1_s1vd, ww2_s1ve #) -> ww2_s1ve } + Tmpl= \ (x_awt [Occ=Once] :: Int) (y_awu [Occ=Once] :: Int) -> + case pm x_awt y_awu of { (_ [Occ=Dead], mr_aww [Occ=Once]) -> mr_aww }}] +m = \ (x_awt :: Int) (y_awu :: Int) -> case T10694.$wpm x_awt y_awu of { (# ww1_s1vp, ww2_s1vq #) -> ww2_s1vq } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T10694.$trModule4 :: GHC.Prim.Addr# -[GblId, - Caf=NoCafRefs, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] T10694.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T10694.$trModule3 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T10694.$trModule3 = GHC.Types.TrNameS T10694.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T10694.$trModule2 :: GHC.Prim.Addr# -[GblId, - Caf=NoCafRefs, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] T10694.$trModule2 = "T10694"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T10694.$trModule1 :: GHC.Types.TrName [GblId, - Caf=NoCafRefs, - Str=m1, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] T10694.$trModule1 = GHC.Types.TrNameS T10694.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T10694.$trModule :: GHC.Types.Module [GblId, - Caf=NoCafRefs, - Str=m, + Cpr=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T10694.$trModule = GHC.Types.Module T10694.$trModule3 T10694.$trModule1 diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index 970417e..c47a0cb 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -33,7 +33,7 @@ test('T9208', when(compiler_debugged(), expect_broken(9208)), compile, ['']) # T9208 fails (and should do so) if you have assertion checking on in the compiler # Hence the above expect_broken. See comments in the ticket -test('T10694', [ grep_errmsg(r'Str=') ], compile, ['-dppr-cols=200 -ddump-simpl']) +test('T10694', [ grep_errmsg(r'(Str|Cpr)=') ], compile, ['-dppr-cols=200 -ddump-simpl']) test('T11770', [ check_errmsg('OneShot') ], compile, ['-ddump-simpl']) test('T13031', normal, makefile_test, []) diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr index 90fc14a..259b596 100644 --- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr +++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr @@ -1,14 +1,21 @@ ==================== Strictness signatures ==================== -BottomFromInnerLambda.$trModule: m -BottomFromInnerLambda.expensive: <S(S),1*U(U)>m +BottomFromInnerLambda.$trModule: +BottomFromInnerLambda.expensive: <S(S),1*U(U)> BottomFromInnerLambda.f: <S(S),1*U(U)> +==================== Cpr signatures ==================== +BottomFromInnerLambda.$trModule: m1 +BottomFromInnerLambda.expensive: m1 +BottomFromInnerLambda.f: + + + ==================== Strictness signatures ==================== -BottomFromInnerLambda.$trModule: m -BottomFromInnerLambda.expensive: <S(S),1*U(1*U)>m +BottomFromInnerLambda.$trModule: +BottomFromInnerLambda.expensive: <S(S),1*U(1*U)> BottomFromInnerLambda.f: <S(S),1*U(1*U)> diff --git a/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr b/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr index f708813..cf95b80 100644 --- a/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr +++ b/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr @@ -1,12 +1,18 @@ ==================== Strictness signatures ==================== -CaseBinderCPR.$trModule: m -CaseBinderCPR.f_list_cmp: <L,C(C1(U(U)))><S,1*U><S,1*U>m +CaseBinderCPR.$trModule: +CaseBinderCPR.f_list_cmp: <L,C(C1(U(U)))><S,1*U><S,1*U> + + + +==================== Cpr signatures ==================== +CaseBinderCPR.$trModule: m1 +CaseBinderCPR.f_list_cmp: m1 ==================== Strictness signatures ==================== -CaseBinderCPR.$trModule: m -CaseBinderCPR.f_list_cmp: <L,C(C1(U(1*U)))><S,1*U><S,1*U>m +CaseBinderCPR.$trModule: +CaseBinderCPR.f_list_cmp: <L,C(C1(U(1*U)))><S,1*U><S,1*U> diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr index fb898f7..96b6bf6 100644 --- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr +++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr @@ -1,28 +1,42 @@ ==================== Strictness signatures ==================== -DmdAnalGADTs.$tc'A: m -DmdAnalGADTs.$tc'B: m -DmdAnalGADTs.$tcD: m -DmdAnalGADTs.$trModule: m +DmdAnalGADTs.$tc'A: +DmdAnalGADTs.$tc'B: +DmdAnalGADTs.$tcD: +DmdAnalGADTs.$trModule: DmdAnalGADTs.diverges: b DmdAnalGADTs.f: <S,1*U> -DmdAnalGADTs.f': <S,1*U>m +DmdAnalGADTs.f': <S,1*U> DmdAnalGADTs.g: <S,1*U> -DmdAnalGADTs.hasCPR: m -DmdAnalGADTs.hasStrSig: <S,1*U(U)>m +DmdAnalGADTs.hasCPR: +DmdAnalGADTs.hasStrSig: <S,1*U(U)> + + + +==================== Cpr signatures ==================== +DmdAnalGADTs.$tc'A: m1 +DmdAnalGADTs.$tc'B: m1 +DmdAnalGADTs.$tcD: m1 +DmdAnalGADTs.$trModule: m1 +DmdAnalGADTs.diverges: b +DmdAnalGADTs.f: +DmdAnalGADTs.f': m1 +DmdAnalGADTs.g: +DmdAnalGADTs.hasCPR: m1 +DmdAnalGADTs.hasStrSig: m1 ==================== Strictness signatures ==================== -DmdAnalGADTs.$tc'A: m -DmdAnalGADTs.$tc'B: m -DmdAnalGADTs.$tcD: m -DmdAnalGADTs.$trModule: m +DmdAnalGADTs.$tc'A: +DmdAnalGADTs.$tc'B: +DmdAnalGADTs.$tcD: +DmdAnalGADTs.$trModule: DmdAnalGADTs.diverges: b DmdAnalGADTs.f: <S,1*U> -DmdAnalGADTs.f': <S,1*U>m +DmdAnalGADTs.f': <S,1*U> DmdAnalGADTs.g: <S,1*U> -DmdAnalGADTs.hasCPR: m -DmdAnalGADTs.hasStrSig: <S,1*U(U)>m +DmdAnalGADTs.hasCPR: +DmdAnalGADTs.hasStrSig: <S,1*U(U)> diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr index 84d81f3..812115e 100644 --- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr +++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr @@ -1,12 +1,18 @@ ==================== Strictness signatures ==================== -HyperStrUse.$trModule: m -HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U>m +HyperStrUse.$trModule: +HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U> + + + +==================== Cpr signatures ==================== +HyperStrUse.$trModule: m1 +HyperStrUse.f: m1 ==================== Strictness signatures ==================== -HyperStrUse.$trModule: m -HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U>m +HyperStrUse.$trModule: +HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U> diff --git a/testsuite/tests/stranal/sigs/NewtypeArity.stderr b/testsuite/tests/stranal/sigs/NewtypeArity.stderr index 08ce83f..5519561 100644 --- a/testsuite/tests/stranal/sigs/NewtypeArity.stderr +++ b/testsuite/tests/stranal/sigs/NewtypeArity.stderr @@ -1,18 +1,27 @@ ==================== Strictness signatures ==================== -Test.$tc'MkT: m -Test.$tcT: m -Test.$trModule: m -Test.t: <S,1*U(U)><S,1*U(U)>m -Test.t2: <S,1*U(U)><S,1*U(U)>m +Test.$tc'MkT: +Test.$tcT: +Test.$trModule: +Test.t: <S,1*U(U)><S,1*U(U)> +Test.t2: <S,1*U(U)><S,1*U(U)> + + + +==================== Cpr signatures ==================== +Test.$tc'MkT: m1 +Test.$tcT: m1 +Test.$trModule: m1 +Test.t: m1 +Test.t2: m1 ==================== Strictness signatures ==================== -Test.$tc'MkT: m -Test.$tcT: m -Test.$trModule: m -Test.t: <S,1*U(U)><S,1*U(U)>m -Test.t2: <S,1*U(U)><S,1*U(U)>m +Test.$tc'MkT: +Test.$tcT: +Test.$trModule: +Test.t: <S,1*U(U)><S,1*U(U)> +Test.t2: <S,1*U(U)><S,1*U(U)> diff --git a/testsuite/tests/stranal/sigs/StrAnalExample.stderr b/testsuite/tests/stranal/sigs/StrAnalExample.stderr index 4cc6f01..f18fb56 100644 --- a/testsuite/tests/stranal/sigs/StrAnalExample.stderr +++ b/testsuite/tests/stranal/sigs/StrAnalExample.stderr @@ -1,12 +1,18 @@ ==================== Strictness signatures ==================== -StrAnalExample.$trModule: m +StrAnalExample.$trModule: StrAnalExample.foo: <S,1*U> +==================== Cpr signatures ==================== +StrAnalExample.$trModule: m1 +StrAnalExample.foo: + + + ==================== Strictness signatures ==================== -StrAnalExample.$trModule: m +StrAnalExample.$trModule: StrAnalExample.foo: <S,1*U> diff --git a/testsuite/tests/stranal/sigs/T12370.stderr b/testsuite/tests/stranal/sigs/T12370.stderr index d1acdf0..63fa76d 100644 --- a/testsuite/tests/stranal/sigs/T12370.stderr +++ b/testsuite/tests/stranal/sigs/T12370.stderr @@ -1,14 +1,21 @@ ==================== Strictness signatures ==================== -T12370.$trModule: m -T12370.bar: <S,1*U(U)><S,1*U(U)>m -T12370.foo: <S(SS),1*U(1*U(U),1*U(U))>m +T12370.$trModule: +T12370.bar: <S,1*U(U)><S,1*U(U)> +T12370.foo: <S(SS),1*U(1*U(U),1*U(U))> + + + +==================== Cpr signatures ==================== +T12370.$trModule: m1 +T12370.bar: m1 +T12370.foo: m1 ==================== Strictness signatures ==================== -T12370.$trModule: m -T12370.bar: <S,1*U(U)><S,1*U(U)>m -T12370.foo: <S(SS),1*U(1*U(U),1*U(U))>m +T12370.$trModule: +T12370.bar: <S,1*U(U)><S,1*U(U)> +T12370.foo: <S(SS),1*U(1*U(U),1*U(U))> diff --git a/testsuite/tests/stranal/sigs/T5075.hs b/testsuite/tests/stranal/sigs/T5075.hs new file mode 100644 index 0000000..c35409a --- /dev/null +++ b/testsuite/tests/stranal/sigs/T5075.hs @@ -0,0 +1,11 @@ +-- | This module currently asserts that we trim CPR for local bindings +-- returning a sum. We can hopefully give @loop@ a CPR signature some day, but +-- we first have to fix #5075/#16570. +module T5075 where + +-- Omission of the type signature is deliberate, otherwise we won't get a join +-- point (this is up to the desugarer, not sure why). +-- loop :: (Ord a, Num a) => a -> Either a b +loop x = case x < 10 of + True -> Left x + False -> loop (x*2) diff --git a/testsuite/tests/stranal/sigs/T5075.stderr b/testsuite/tests/stranal/sigs/T5075.stderr new file mode 100644 index 0000000..582f62d --- /dev/null +++ b/testsuite/tests/stranal/sigs/T5075.stderr @@ -0,0 +1,18 @@ + +==================== Strictness signatures ==================== +T5075.$trModule: +T5075.loop: <S(LLC(C(S))LLLLL),U(A,A,C(C1(U)),A,A,A,A,A)><L,U(A,A,C(C1(U)),A,A,A,C(U))><L,U> + + + +==================== Cpr signatures ==================== +T5075.$trModule: m1 +T5075.loop: + + + +==================== Strictness signatures ==================== +T5075.$trModule: +T5075.loop: <S(LLC(C(S))LLLLL),1*U(A,A,C(C1(U)),A,A,A,A,A)><L,U(A,A,C(C1(U)),A,A,A,C(U))><L,U> + + diff --git a/testsuite/tests/stranal/sigs/T8569.stderr b/testsuite/tests/stranal/sigs/T8569.stderr index 10d962e..122f748 100644 --- a/testsuite/tests/stranal/sigs/T8569.stderr +++ b/testsuite/tests/stranal/sigs/T8569.stderr @@ -1,18 +1,27 @@ ==================== Strictness signatures ==================== -T8569.$tc'Rdata: m -T8569.$tc'Rint: m -T8569.$tcRep: m -T8569.$trModule: m +T8569.$tc'Rdata: +T8569.$tc'Rint: +T8569.$tcRep: +T8569.$trModule: T8569.addUp: <S,1*U><L,U> +==================== Cpr signatures ==================== +T8569.$tc'Rdata: m1 +T8569.$tc'Rint: m1 +T8569.$tcRep: m1 +T8569.$trModule: m1 +T8569.addUp: + + + ==================== Strictness signatures ==================== -T8569.$tc'Rdata: m -T8569.$tc'Rint: m -T8569.$tcRep: m -T8569.$trModule: m +T8569.$tc'Rdata: +T8569.$tc'Rint: +T8569.$tcRep: +T8569.$trModule: T8569.addUp: <S,1*U><L,U> diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr index 9bf10d9..d679360 100644 --- a/testsuite/tests/stranal/sigs/T8598.stderr +++ b/testsuite/tests/stranal/sigs/T8598.stderr @@ -1,12 +1,18 @@ ==================== Strictness signatures ==================== -T8598.$trModule: m -T8598.fun: <S,1*U(U)>m +T8598.$trModule: +T8598.fun: <S,1*U(U)> + + + +==================== Cpr signatures ==================== +T8598.$trModule: m1 +T8598.fun: m1 ==================== Strictness signatures ==================== -T8598.$trModule: m -T8598.fun: <S,1*U(U)>m +T8598.$trModule: +T8598.fun: <S,1*U(U)> diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr index 9fb8ab3..1f5a58b 100644 --- a/testsuite/tests/stranal/sigs/UnsatFun.stderr +++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr @@ -1,24 +1,36 @@ ==================== Strictness signatures ==================== -UnsatFun.$trModule: m +UnsatFun.$trModule: UnsatFun.f: <B,1*U(U)><B,A>b UnsatFun.g: <B,1*U(U)>b UnsatFun.g': <L,1*U(U)> -UnsatFun.g3: <L,U(U)>m +UnsatFun.g3: <L,U(U)> UnsatFun.h: <C(S),1*C1(U(U))> UnsatFun.h2: <S,1*U><L,1*C1(U(U))> -UnsatFun.h3: <C(S),1*C1(U)>m +UnsatFun.h3: <C(S),1*C1(U)> + + + +==================== Cpr signatures ==================== +UnsatFun.$trModule: m1 +UnsatFun.f: b +UnsatFun.g: +UnsatFun.g': +UnsatFun.g3: m1 +UnsatFun.h: +UnsatFun.h2: +UnsatFun.h3: m1 ==================== Strictness signatures ==================== -UnsatFun.$trModule: m +UnsatFun.$trModule: UnsatFun.f: <B,1*U(U)><B,A>b UnsatFun.g: <B,1*U(U)>b UnsatFun.g': <L,1*U(U)> -UnsatFun.g3: <L,U(U)>m +UnsatFun.g3: <L,U(U)> UnsatFun.h: <C(S),1*C1(U(U))> UnsatFun.h2: <S,1*U><L,1*C1(U(U))> -UnsatFun.h3: <C(S),1*C1(U)>m +UnsatFun.h3: <C(S),1*C1(U)> diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T index fca319f..f7cbd37 100644 --- a/testsuite/tests/stranal/sigs/all.T +++ b/testsuite/tests/stranal/sigs/all.T @@ -1,7 +1,7 @@ # This directory contains tests where we annotate functions with expected # type signatures, and verify that these actually those found by the compiler -setTestOpts(extra_hc_opts('-ddump-str-signatures')) +setTestOpts(extra_hc_opts('-ddump-str-signatures -ddump-cpr-signatures')) # We are testing the result of an optimization, so no use # running them in various runtimes @@ -18,3 +18,4 @@ test('DmdAnalGADTs', normal, compile, ['']) test('T12370', normal, compile, ['']) test('CaseBinderCPR', normal, compile, ['']) test('NewtypeArity', normal, compile, ['']) +test('T5075', normal, compile, ['']) |