[Git][ghc/ghc][wip/nested-cpr-2019] 4 commits: Accept testuite output
Sebastian Graf
gitlab at gitlab.haskell.org
Mon May 11 16:25:45 UTC 2020
Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC
Commits:
3eb58822 by Sebastian Graf at 2020-05-06T16:28:23+02:00
Accept testuite output
- - - - -
1e11fa0e by Sebastian Graf at 2020-05-06T16:29:11+02:00
Don't attach CPR sigs to expandable bindings; transform their unfoldings instead
- - - - -
8d6128c3 by Sebastian Graf at 2020-05-06T16:47:34+02:00
Revert "Don't give the case binder the CPR property"
This reverts commit 910edd76d5fe68b58c74f3805112f9faef4f2788.
It seems we broke too much with this change. We lost our big win in
`fish`.
- - - - -
c015b648 by Sebastian Graf at 2020-05-11T18:25:36+02:00
A more modular and configurable approach to optimistic case binder CPR
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Cpr.hs
- testsuite/tests/cpranal/sigs/DataConWrapperCpr.stderr
- testsuite/tests/simplCore/should_compile/T7360.stderr
- testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
- testsuite/tests/stranal/sigs/NewtypeArity.stderr
- testsuite/tests/stranal/sigs/T17932.stderr
- testsuite/tests/stranal/sigs/T8569.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -27,12 +27,13 @@ import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram )
+import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.FamInstEnv
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Utils.Misc
import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) )
-import GHC.Data.Maybe ( isNothing )
+import GHC.Data.Maybe ( isJust, isNothing )
{- Note [Constructed Product Result]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -104,7 +105,7 @@ So currently we have
cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
cprAnalProgram dflags fam_envs binds = do
- let env = emptyAnalEnv fam_envs
+ let env = emptyAnalEnv dflags 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
@@ -204,8 +205,8 @@ cprAnal' env args (Case scrut case_bndr ty alts)
-- head strictness.
(scrut_ty, scrut') = cprAnal env [] scrut
(whnf_flag, case_bndr_ty) = forceCprTy (getStrDmd seqDmd) scrut_ty
- (alt_tys, alts') = mapAndUnzip (cprAnalAlt env args case_bndr case_bndr_ty) alts
- res_ty = lubCprTypes alt_tys `bothCprType` whnf_flag
+ (alt_tys, alts') = mapAndUnzip (cprAnalAlt env args case_bndr case_bndr_ty) alts
+ res_ty = lubCprTypes alt_tys `bothCprType` whnf_flag
cprAnal' env args (Let (NonRec id rhs) body)
= (body_ty, Let (NonRec id' rhs') body')
@@ -255,6 +256,8 @@ cprTransform env args id
sig
| Just con <- isDataConWorkId_maybe id -- Data constructor
= cprTransformDataConSig con args
+ | Just rhs <- lookupExpandableUnfolding id
+ = fst $ cprAnal env args rhs
| isGlobalId id -- imported function or data con worker
= cprTransformSig (idStrictness id) (idCprInfo id) args
| Just sig <- lookupSigEnv env id -- local let-bound
@@ -378,11 +381,14 @@ cprAnalBind top_lvl env args id rhs
| stays_thunk = trimCprTy rhs_ty
-- See Note [CPR for sum types]
| returns_sum = trimCprTy rhs_ty
+ -- See Note [CPR for expandable unfoldings]
+ | will_expand = topCprType
| otherwise = rhs_ty
-- See Note [Arity trimming for CPR signatures]
-- We prune so that we discard too deep info on e.g. TyCon bindings
- sig = pruneSig mAX_DEPTH $ mkCprSigForArity (idArity id) rhs_ty'
+ dflags = ae_dflags env
+ sig = pruneSig mAX_DEPTH $ mkCprSigForArity dflags (idArity id) rhs_ty'
id' = -- pprTrace "cprAnalBind" (ppr id $$ ppr sig) $
setIdCprInfo id sig
@@ -394,6 +400,19 @@ cprAnalBind top_lvl env args id rhs
(_, 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
+ -- See Note [CPR for expandable unfoldings]
+ will_expand = isJust (lookupExpandableUnfolding id)
+
+lookupExpandableUnfolding :: Id -> Maybe CoreExpr
+lookupExpandableUnfolding id
+ | idArity id == 0 = expandUnfolding_maybe (cprIdUnfolding id)
+ | otherwise = Nothing
+
+cprIdUnfolding :: IdUnfoldingFun
+cprIdUnfolding id
+ -- There will only be phase 0 Simplifier runs after CprAnal
+ | isActiveIn 0 (idInlineActivation id) = idUnfolding id
+ | otherwise = noUnfolding
{- Note [Arity trimming for CPR signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -434,6 +453,8 @@ data AnalEnv
, ae_virgin :: Bool
-- ^ True only on every first iteration in a fixed-point
-- iteration. See Note [Initialising strictness] in "DmdAnal"
+ , ae_dflags :: DynFlags
+ -- ^ For 'caseBinderCprDepth'.
, ae_fam_envs :: FamInstEnvs
-- ^ Needed when expanding type families and synonyms of product types.
}
@@ -446,11 +467,12 @@ instance Outputable AnalEnv where
[ text "ae_virgin =" <+> ppr virgin
, text "ae_sigs =" <+> ppr env ])
-emptyAnalEnv :: FamInstEnvs -> AnalEnv
-emptyAnalEnv fam_envs
+emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
+emptyAnalEnv dflags fam_envs
= AE
{ ae_sigs = emptyVarEnv
, ae_virgin = True
+ , ae_dflags = dflags
, ae_fam_envs = fam_envs
}
@@ -478,10 +500,19 @@ nonVirgin env = env { ae_virgin = False }
extendEnvForDataAlt :: AnalEnv -> Id -> CprType -> DataCon -> [Var] -> AnalEnv
-- See Note [CPR in a DataAlt case alternative]
extendEnvForDataAlt env case_bndr case_bndr_ty dc bndrs
- = extendAnalEnv env' case_bndr (CprSig case_bndr_ty)
+ = extendAnalEnv env' case_bndr (CprSig case_bndr_ty')
where
+ tycon = dataConTyCon dc
+ is_product = isJust (isDataProductTyCon_maybe tycon)
+ is_sum = isJust (isDataSumTyCon_maybe tycon)
+ case_bndr_ty'
+ | is_product || is_sum = markOptimisticConCprType dc case_bndr_ty
+ -- 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 = case_bndr_ty
env'
- | Just fields <- splitConCprTy dc case_bndr_ty
+ | Just fields <- splitConCprTy dc case_bndr_ty'
, let ids = filter isId bndrs
, let cpr_tys = map (CprSig . CprType 0) fields
= extendAnalEnvList env (zipEqual "extendEnvForDataAlt" ids cpr_tys)
@@ -673,6 +704,28 @@ 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.
+Should we also trim CPR on DataCon bindings?
+See Note [CPR for expandable unfoldings]!
+
+Note [CPR for expandable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC generates a lot of TyCon and KindRep bindings, one for each new data
+declaration. Attaching CPR signatures to each of them is quite wasteful.
+In general, DataCon application bindings
+ * Never get WW'd, so their CPR signature should be irrelevant after analysis
+ * Would need to be inlined to see their CPR
+ * Recording (Nested!) CPR on them blows up interface file sizes
+But we can't just stop giving DataCon application bindings the CPR property,
+for example
+ fac 0 = 1
+ fac n = n * fac (n-1)
+fac certainly has the CPR property and should be WW'd! But FloatOut will
+transform the first clause to
+ lvl = 1
+ fac 0 = lvl
+If lvl doesn't have the CPR property, fac won't either. So instead we keep on
+looking through *expandable* unfoldings for these arity 0 bindings.
+
Note [CPR examples]
~~~~~~~~~~~~~~~~~~~~
Here are some examples (stranal/should_compile/T10482a) of the
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -191,6 +191,7 @@ data GeneralFlag
| Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm.
| Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block.
| Opt_CprAnal
+ | Opt_CaseBinderCpr -- ^ Optimistically give returned case binders the CPR property
| Opt_WorkerWrapper
| Opt_SolveConstantDicts
| Opt_AlignmentSanitisation
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -497,6 +497,9 @@ data DynFlags = DynFlags {
specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function
specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types
-- Not optional; otherwise ForceSpecConstr can diverge.
+ caseBinderCprDepth :: Int, -- ^ How many levels deep a case binder
+ -- should optimistically get the CPR property.
+
binBlobThreshold :: Word, -- ^ Binary literals (e.g. strings) whose size is above
-- this threshold will be dumped in a binary file
-- by the assembler code generator (0 to disable)
@@ -1303,6 +1306,7 @@ defaultDynFlags mySettings llvmConfig =
specConstrCount = Just 3,
specConstrRecursive = 3,
liberateCaseThreshold = Just 2000,
+ caseBinderCprDepth = 1, -- The default prior to Nested CPR
floatLamArgs = Just 0, -- Default: float only if no fvs
liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64
liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64
@@ -2971,6 +2975,8 @@ dynamic_flags_deps = [
(intSuffix (\n d -> d { liberateCaseThreshold = Just n }))
, make_ord_flag defFlag "fno-liberate-case-threshold"
(noArg (\d -> d { liberateCaseThreshold = Nothing }))
+ , make_ord_flag defFlag "fcase-binder-cpr-depth"
+ (intSuffix (\n d -> d { caseBinderCprDepth = n }))
, make_ord_flag defFlag "drule-check"
(sepArg (\s d -> d { ruleCheck = Just s }))
, make_ord_flag defFlag "dinline-check"
@@ -3526,6 +3532,7 @@ fFlagsDeps = [
flagSpec "stg-cse" Opt_StgCSE,
flagSpec "stg-lift-lams" Opt_StgLiftLams,
flagSpec "cpr-anal" Opt_CprAnal,
+ flagSpec "case-binder-cpr" Opt_CaseBinderCpr,
flagSpec "defer-diagnostics" Opt_DeferDiagnostics,
flagSpec "defer-type-errors" Opt_DeferTypeErrors,
flagSpec "defer-typed-holes" Opt_DeferTypedHoles,
@@ -4094,6 +4101,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
, ([1,2], Opt_Strictness)
, ([1,2], Opt_UnboxSmallStrictFields)
, ([1,2], Opt_CprAnal)
+ , ([1,2], Opt_CaseBinderCpr)
, ([1,2], Opt_WorkerWrapper)
, ([1,2], Opt_SolveConstantDicts)
, ([1,2], Opt_NumConstantFolding)
=====================================
compiler/GHC/Types/Cpr.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Types.Cpr (
TerminationFlag (Terminates),
Cpr, topCpr, conCpr, whnfTermCpr, divergeCpr, lubCpr, asConCpr,
CprType (..), topCprType, whnfTermCprType, conCprType, lubCprType, lubCprTypes,
- pruneDeepCpr, splitConCprTy, applyCprTy, abstractCprTy,
+ pruneDeepCpr, markOptimisticConCprType, splitConCprTy, applyCprTy, abstractCprTy,
abstractCprTyNTimes, ensureCprTyArity, trimCprTy,
forceCprTy, forceCpr, bothCprType,
cprTransformDataConSig, UnboxingStrategy, cprTransformSig, argCprTypesFromStrictSig,
@@ -28,6 +28,7 @@ import GHC.Types.Basic
import GHC.Types.Demand
import GHC.Core.DataCon
import GHC.Core.Type
+import GHC.Driver.Session
import GHC.Utils.Binary
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -82,8 +83,17 @@ pruneKnownShape _ 0 _ = Top
pruneKnownShape prune_r depth (Con t args) = Levitate (Con t (map (prune_r (depth - 1)) args))
---------------
--- * Termination
+-- * Optimism
+
+data Optimism
+ = Conservative
+ | Optimistic
+ deriving Eq
+lubOptimism :: Optimism -> Optimism -> Optimism
+lubOptimism Optimistic _ = Optimistic
+lubOptimism _ Optimistic = Optimistic
+lubOptimism Conservative Conservative = Conservative
----------------
-- * Termination
@@ -171,7 +181,7 @@ seqTerm (Term _ l) = seqLevitated (seqKnownShape seqTerm) l
-- * Cpr
data Cpr
- = Cpr !TerminationFlag !(Levitated (KnownShape Cpr))
+ = Cpr !Optimism !TerminationFlag !(Levitated (KnownShape Cpr))
| NoMoreCpr_ !Termination
deriving Eq
@@ -185,13 +195,13 @@ pattern NoMoreCpr t <- (NoMoreCpr_ t)
{-# COMPLETE Cpr, NoMoreCpr #-}
botCpr :: Cpr
-botCpr = Cpr Terminates Bot
+botCpr = Cpr Conservative Terminates Bot
topCpr :: Cpr
-topCpr = Cpr MightDiverge Top
+topCpr = Cpr Conservative MightDiverge Top
whnfTermCpr :: Cpr
-whnfTermCpr = Cpr Terminates Top
+whnfTermCpr = Cpr Conservative Terminates Top
-- | Used as
--
@@ -203,41 +213,45 @@ whnfTermCpr = Cpr Terminates Top
-- assume that returned tuple components terminate rapidly and construct a
-- product.
divergeCpr :: Cpr
-divergeCpr = Cpr MightDiverge Bot
+divergeCpr = Cpr Conservative MightDiverge Bot
conCpr :: ConTag -> [Cpr] -> Cpr
-conCpr t fs = Cpr Terminates (Levitate (Con t fs))
+conCpr t fs = Cpr Conservative Terminates (Levitate (Con t fs))
+
+optimisticConCpr :: ConTag -> [Cpr] -> Cpr
+optimisticConCpr t fs = Cpr Optimistic Terminates (Levitate (Con t fs))
-- | Forget encoded CPR info, but keep termination info.
forgetCpr :: Cpr -> Termination
forgetCpr (NoMoreCpr t) = t
-forgetCpr (Cpr tf l_sh) = Term tf (normTermShape (liftLevitated go l_sh))
+forgetCpr (Cpr _ tf l_sh) = Term tf (normTermShape (liftLevitated go l_sh))
where
go (Con t fields) = Levitate (Con t (map forgetCpr fields))
lubCpr :: Cpr -> Cpr -> Cpr
-lubCpr (Cpr tf1 l_sh1) (Cpr tf2 l_sh2)
- = Cpr (lubTermFlag tf1 tf2)
+lubCpr (Cpr op1 tf1 l_sh1) (Cpr op2 tf2 l_sh2)
+ = Cpr (lubOptimism op1 op2)
+ (lubTermFlag tf1 tf2)
(lubLevitated (lubKnownShape lubCpr) l_sh1 l_sh2)
lubCpr cpr1 cpr2
= NoMoreCpr (lubTerm (forgetCpr cpr1) (forgetCpr cpr2))
trimCpr :: Cpr -> Cpr
-trimCpr cpr@(Cpr _ Bot) = cpr -- don't trim away bottom (we didn't do so before Nested CPR) TODO: Explain; CPR'ing for the error case
-trimCpr cpr = NoMoreCpr (forgetCpr cpr)
+trimCpr cpr@(Cpr _ _ Bot) = cpr -- don't trim away bottom (we didn't do so before Nested CPR) TODO: Explain; CPR'ing for the error case
+trimCpr cpr = NoMoreCpr (forgetCpr cpr)
pruneDeepCpr :: Int -> Cpr -> Cpr
-pruneDeepCpr depth (Cpr tf (Levitate sh)) = Cpr tf (pruneKnownShape pruneDeepCpr depth sh)
-pruneDeepCpr depth (NoMoreCpr t) = NoMoreCpr (pruneDeepTerm depth t)
-pruneDeepCpr _ cpr = cpr
+pruneDeepCpr depth (Cpr op tf (Levitate sh)) = Cpr op tf (pruneKnownShape pruneDeepCpr depth sh)
+pruneDeepCpr depth (NoMoreCpr t) = NoMoreCpr (pruneDeepTerm depth t)
+pruneDeepCpr _ cpr = cpr
asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
-asConCpr (Cpr tf (Levitate (Con t fields)))
+asConCpr (Cpr _ tf (Levitate (Con t fields)))
| Terminates <- tf = Just (t, fields)
asConCpr _ = Nothing
seqCpr :: Cpr -> ()
-seqCpr (Cpr _ l) = seqLevitated (seqKnownShape seqCpr) l
+seqCpr (Cpr _ _ l) = seqLevitated (seqKnownShape seqCpr) l
seqCpr (NoMoreCpr t) = seqTerm t
------------
@@ -302,8 +316,23 @@ conCprType con_tag args = CprType 0 (conCpr con_tag cprs)
where
cprs = extractArgCprAndTermination args
+markOptimisticConCprType :: DataCon -> CprType -> CprType
+markOptimisticConCprType dc _ty@(CprType n cpr)
+ = ASSERT2( n == 0, ppr _ty ) CprType 0 (optimisticConCpr con_tag fields)
+ where
+ con_tag = dataConTag dc
+ wkr_arity = dataConRepArity dc
+ fields = case cpr of
+ NoMoreCpr (Term _ (Levitate (Con t terms)))
+ | con_tag == t -> map NoMoreCpr terms
+ NoMoreCpr (Term _ Bot) -> replicate wkr_arity (NoMoreCpr botTerm)
+ Cpr _ _ (Levitate (Con t cprs))
+ | con_tag == t -> cprs
+ Cpr _ _ Bot -> replicate wkr_arity botCpr
+ _ -> replicate wkr_arity topCpr
+
splitConCprTy :: DataCon -> CprType -> Maybe [Cpr]
-splitConCprTy dc (CprType 0 (Cpr _ l))
+splitConCprTy dc (CprType 0 (Cpr _ _ l))
| Bot <- l
= Just (replicate (dataConRepArity dc) botCpr)
| Levitate (Con t fields) <- l
@@ -334,6 +363,22 @@ ensureCprTyArity n ty@(CprType m _)
trimCprTy :: CprType -> CprType
trimCprTy (CprType arty cpr) = CprType arty (trimCpr cpr)
+zonkOptimisticCprTy :: Int -> CprType -> CprType
+zonkOptimisticCprTy max_depth (CprType arty cpr)
+ = CprType arty (zonk max_depth cpr)
+ where
+ -- | The Int is the amount of "fuel" left; when it reaches 0, we no longer
+ -- turn OptimisticCpr into Cpr, but into NoMoreCpr.
+ zonk :: Int -> Cpr -> Cpr
+ zonk n (Cpr op tf sh)
+ | n > 0 || op == Conservative
+ = Cpr Conservative tf (liftLevitated (Levitate . zonk_sh (n-1)) sh)
+ zonk _ cpr
+ = NoMoreCpr (forgetCpr cpr)
+
+ zonk_sh :: Int -> KnownShape Cpr -> KnownShape Cpr
+ zonk_sh n (Con t fields) = Con t (map (zonk n) fields)
+
-- | Abusing the Monoid instance of 'Semigroup.Any' to track a
-- 'TerminationFlag'.
newtype TerminationM a = TerminationM (Writer Semigroup.Any a)
@@ -364,9 +409,9 @@ forceCprTyM arg_str ty = go (toStrDmd arg_str) ty
abstractCprTy <$> go (swap (peelStrCall str)) (applyCprTy ty)
forceCprM :: ArgStr -> Cpr -> TerminationM Cpr
-forceCprM Lazy t = return t
-forceCprM arg_str (NoMoreCpr t) = NoMoreCpr <$> forceTermM arg_str t
-forceCprM (Str str) (Cpr tf l_sh) = do
+forceCprM Lazy t = return t
+forceCprM arg_str (NoMoreCpr t) = NoMoreCpr <$> forceTermM arg_str t
+forceCprM (Str str) (Cpr op tf l_sh) = do
-- 1. discharge head strictness by noting the term flag
noteTermFlag tf
-- 2. discharge *nested* strictness on available nested info
@@ -393,7 +438,7 @@ forceCprM (Str str) (Cpr tf l_sh) = do
#endif
fields' <- zipWithM forceCprM args fields
return (Levitate (Con fIRST_TAG fields'))
- return (Cpr Terminates l_sh')
+ return (Cpr op Terminates l_sh')
forceTermM :: ArgStr -> Termination -> TerminationM Termination
forceTermM Lazy t = return t
@@ -439,7 +484,7 @@ bothCprType ct MightDiverge = ct { ct_cpr = shallowDivCpr (ct_cpr ct) }
shallowDivCpr :: Cpr -> Cpr
shallowDivCpr (NoMoreCpr (Term _ l_sh)) = NoMoreCpr (Term MightDiverge l_sh)
-shallowDivCpr (Cpr _ l_sh) = Cpr MightDiverge l_sh
+shallowDivCpr (Cpr op _ l_sh) = Cpr op MightDiverge l_sh
seqCprType :: CprType -> ()
seqCprType (CprType _ cpr) = seqCpr cpr
@@ -449,14 +494,18 @@ seqCprType (CprType _ cpr) = seqCpr cpr
-- | The arity of the wrapped 'CprType' is the arity at which it is safe
-- to unleash. See Note [Understanding DmdType and StrictSig] in GHC.Types.Demand
+-- INVARIANT: The wrapped CprType never has 'OptimisticCpr' somewhere.
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)
+mkCprSigForArity :: DynFlags -> Arity -> CprType -> CprSig
+mkCprSigForArity dflags arty
+ = CprSig
+ . ensureCprTyArity arty
+ . zonkOptimisticCprTy (caseBinderCprDepth dflags)
topCprSig :: CprSig
topCprSig = CprSig topCprType
@@ -559,15 +608,19 @@ instance Outputable Termination where
Bot -> text "(#..)"
Levitate shape -> ppr shape
+instance Outputable Optimism where
+ ppr Optimistic = char '?'
+ ppr Conservative = empty
+
instance Outputable Cpr where
ppr (NoMoreCpr t) = ppr t
-- I like it better without the special case
-- ppr (Cpr MightDiverge Top) = empty
-- ppr (Cpr Terminates Bot) = char 'b'
- ppr (Cpr tf l) = ppr tf <> case l of
+ ppr (Cpr op tf l) = ppr tf <> case l of
Top -> empty
Bot -> char 'b'
- Levitate shape -> char 'c' <> ppr shape
+ Levitate shape -> char 'c' <> ppr op <> ppr shape
instance Outputable CprType where
ppr (CprType arty cpr) = ppr arty <+> ppr cpr
@@ -604,17 +657,28 @@ instance Binary TerminationFlag where
then pure Terminates
else pure MightDiverge
+-- | In practice, we should never need to serialise an 'Optimistic' because of
+-- the invariant attached to 'CprSig'.
+instance Binary Optimism where
+ put_ bh Conservative = put_ bh True
+ put_ bh Optimistic = put_ bh False
+ get bh = do
+ b <- get bh
+ if b
+ then pure Conservative
+ else pure Optimistic
+
instance Binary Termination where
put_ bh (Term tf l) = put_ bh tf >> put_ bh l
get bh = Term <$> get bh <*> get bh
instance Binary Cpr where
- put_ bh (Cpr tf l) = put_ bh True >> put_ bh tf >> put_ bh l
+ put_ bh (Cpr op tf l) = put_ bh True >> put_ bh op >> put_ bh tf >> put_ bh l
put_ bh (NoMoreCpr t) = put_ bh False >> put_ bh t
get bh = do
b <- get bh
if b
- then Cpr <$> get bh <*> get bh
+ then Cpr <$> get bh <*> get bh <*> get bh
else NoMoreCpr <$> get bh
instance Binary CprType where
=====================================
testsuite/tests/cpranal/sigs/DataConWrapperCpr.stderr
=====================================
@@ -2,8 +2,7 @@
==================== Cpr signatures ====================
DataConWrapperCpr.$tc'Foo: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#),
#,
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *)))
+ #c4(#c1(#c1(#, #, #, #, #, #), *), #c1(#c1(#, #, #, #, #, #), *)))
DataConWrapperCpr.$tcFoo: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
#c5(*))
DataConWrapperCpr.$trModule: #c1(#c1(#), #c1(#))
=====================================
testsuite/tests/simplCore/should_compile/T7360.stderr
=====================================
@@ -164,7 +164,7 @@ T7360.$tc'Foo5 = GHC.Types.TrNameS T7360.$tc'Foo6
T7360.$tc'Foo1 :: GHC.Types.TyCon
[GblId,
Cpr=#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *)),
+ #c1(#c1(#, #, #c1(#, #), #c1(#), #, #c5(*)), *)),
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}]
T7360.$tc'Foo1
@@ -196,7 +196,7 @@ T7360.$tc'Foo7 = GHC.Types.TrNameS T7360.$tc'Foo8
T7360.$tc'Foo2 :: GHC.Types.TyCon
[GblId,
Cpr=#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *)),
+ #c1(#c1(#, #, #c1(#, #), #c1(#), #, #c5(*)), *)),
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}]
T7360.$tc'Foo2
@@ -211,8 +211,8 @@ T7360.$tc'Foo2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T7360.$tc'Foo9 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep
[GblId,
- Cpr=#c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *)),
+ Cpr=#c4(#c1(#c1(#, #, #c1(#, #), #c1(#), #, #c5(*)), *),
+ #c1(#c1(#, #, #c1(#, #), #c1(#), #, #c5(*)), *)),
Unf=OtherCon []]
T7360.$tc'Foo9 = GHC.Types.KindRepFun $krep T7360.$tc'Foo4
@@ -236,8 +236,7 @@ T7360.$tc'Foo10 = GHC.Types.TrNameS T7360.$tc'Foo11
T7360.$tc'Foo3 :: GHC.Types.TyCon
[GblId,
Cpr=#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *))),
+ #c4(#c1(#c1(#, #, #, #, #, #), *), #c1(#c1(#, #, #, #, #, #), *))),
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}]
T7360.$tc'Foo3
=====================================
testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
=====================================
@@ -15,13 +15,9 @@ DmdAnalGADTs.hasStrSig: <S,1*U>
==================== Cpr signatures ====================
DmdAnalGADTs.$tc'A: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c4(#c5(*), #c5(*))),
- #c2(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *), *)))
+ #c1(#c1(#, #, #c1(#, #), #c1(#), #, #c4(#, #)), #c2(#c1(#, *), *)))
DmdAnalGADTs.$tc'B: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c4(#c5(*), #c5(*))),
- #c2(#c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *)),
- *)))
+ #c1(#c1(#, #, #c1(#, #), #c1(#), #, #c4(#, #)), #c2(#c4(#, #), *)))
DmdAnalGADTs.$tcD: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
#c4(#c5(*), #c5(*)))
DmdAnalGADTs.$trModule: #c1(#c1(#), #c1(#))
=====================================
testsuite/tests/stranal/sigs/NewtypeArity.stderr
=====================================
@@ -10,10 +10,7 @@ Test.t2: <S,1*U(U)><S,1*U(U)>
==================== Cpr signatures ====================
Test.$tc'MkT: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *))),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *)))
+ #c4(#c4(#c1(#, *), #c4(#, #)), #c1(#c1(#, #, #, #, #, #), *)))
Test.$tcT: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*))
Test.$trModule: #c1(#c1(#), #c1(#))
Test.t: #c1(#)
=====================================
testsuite/tests/stranal/sigs/T17932.stderr
=====================================
@@ -11,22 +11,10 @@ T17932.flags: <S(SS),1*U(1*U,1*U)>
==================== Cpr signatures ====================
T17932.$tc'Options: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c5(*), #c5(*))),
- #c2(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- *)),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *))))
+ #c4(#c1(#c1(#, #, #, #, #, #), *), #c4(#c1(#, #), #c1(#, *))))
T17932.$tc'X: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c5(*), #c5(*))),
- #c2(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *), *)),
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)),
- *)))))))
+ #c4(#c1(#c1(#, #, #, #, #, #), #c2(#, *)),
+ #c4(#c1(#, *), #c4(#, #))))
T17932.$tcOptions: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
#c5(*))
T17932.$tcX: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*))
=====================================
testsuite/tests/stranal/sigs/T8569.stderr
=====================================
@@ -10,15 +10,10 @@ T8569.addUp: <S,1*U><L,U>
==================== Cpr signatures ====================
T8569.$tc'Rdata: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c4(#c5(*), #c5(*))),
- #c2(#c2(#), *)),
- #c4(#c4(#c2(#), #c2(#)),
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c4(#c5(*), #c5(*))),
- #c2(#c2(#), *)))))
+ #c4(#c1(#c1(#, #, #, #, #, #), #c2(#, *)),
+ #c4(#c4(#, #), #c1(#, #))))
T8569.$tc'Rint: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
- #c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c4(#c5(*), #c5(*))),
- #c2(#c1(#c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #, #c5(*)), *), *)))
+ #c1(#c1(#, #, #c1(#, #), #c1(#), #, #c4(#, #)), #c2(#c1(#, *), *)))
T8569.$tcRep: #c1(#, #, #c1(#c1(#), #c1(#)), #c1(#), #,
#c4(#c5(*), #c5(*)))
T8569.$trModule: #c1(#c1(#), #c1(#))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75867eac718bdc371d286c92c3a66797e0eef505...c015b648580edf071e10dd197fda5727dca66750
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75867eac718bdc371d286c92c3a66797e0eef505...c015b648580edf071e10dd197fda5727dca66750
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200511/35601a74/attachment-0001.html>
More information about the ghc-commits
mailing list