...
 
Commits (8)
......@@ -31,7 +31,6 @@ import GHC.Runtime.Heap.Layout
import UniqSupply
import CostCentre
import GHC.StgToCmm.Heap
import ErrUtils
import Control.Monad
import Data.Map.Strict (Map)
......@@ -802,9 +801,6 @@ doSRTs dflags moduleSRTInfo procs data_ = do
(srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result
srt_decls = concat srt_declss
unless (null srt_decls) $
dumpIfSet_dyn dflags Opt_D_dump_srts "SRTs" FormatCMM (ppr srt_decls)
-- Next, update the info tables with the SRTs
let
srtFieldMap = mapFromList (concat pairs)
......
......@@ -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)
......
......@@ -758,11 +758,12 @@ positions in the kind of the tycon.
mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@.
-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@
-- See Note [Detecting forced eta expansion] in "DsExpr"
mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e
mkHsWrap co_fn (HsPar x (L l e)) = HsPar x (L l (mkHsWrap co_fn e))
mkHsWrap co_fn e = XExpr (HsWrap co_fn e)
mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
......
......@@ -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
......
......@@ -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)
......
......@@ -1102,10 +1102,7 @@ pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
pprIfaceForAllBndr bndr =
case bndr of
Bndr (IfaceTvBndr tv) Inferred ->
sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitForalls dflags
then braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False)
else pprIfaceTvBndr tv suppress_sig (UseBndrParens True)
braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False)
Bndr (IfaceTvBndr tv) _ ->
pprIfaceTvBndr tv suppress_sig (UseBndrParens True)
Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv
......
......@@ -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)
......
{-# 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
This diff is collapsed.
......@@ -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
......@@ -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
}
......
......@@ -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.
......
......@@ -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)
......
......@@ -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" <+>
......
......@@ -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)
......
......@@ -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
......@@ -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
......
......@@ -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 '>']
This diff is collapsed.
......@@ -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
......
......@@ -427,7 +427,6 @@ data DumpFlag
| Opt_D_dump_cmm_split
| Opt_D_dump_cmm_info
| Opt_D_dump_cmm_cps
| Opt_D_dump_srts
-- end cmm subflags
| Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout.
| Opt_D_dump_asm
......@@ -464,6 +463,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
......@@ -3358,8 +3359,6 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_cmm_info)
, make_ord_flag defGhcFlag "ddump-cmm-cps"
(setDumpFlag Opt_D_dump_cmm_cps)
, make_ord_flag defGhcFlag "ddump-srts"
(setDumpFlag Opt_D_dump_srts)
, make_ord_flag defGhcFlag "ddump-cfg-weights"
(setDumpFlag Opt_D_dump_cfg_weights)
, make_ord_flag defGhcFlag "ddump-core-stats"
......@@ -3430,6 +3429,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"
......
......@@ -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
------------------------------------------------------------------------
......
......@@ -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)
......
......@@ -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"
......
......@@ -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
......
......@@ -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
......
......@@ -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:
......
......@@ -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
......
......@@ -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
......
This diff is collapsed.
This diff is collapsed.
......@@ -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
{-
......
......@@ -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)
......
......@@ -1866,17 +1866,14 @@ zonkTcTyConToTyCon tc
zonkTcTypeToType :: TcType -> TcM Type
zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty
zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
zonkTcTypeToTypeX = mapType zonk_tycomapper