From 044e5be3b595858d0d689e27dad427bbdbf26cb4 Mon Sep 17 00:00:00 2001
From: Sebastian Graf <sebastian.graf@kit.edu>
Date: Thu, 18 Feb 2021 14:38:17 +0100
Subject: [PATCH] Nested CPR light (#19398)
While fixing #19232, it became increasingly clear that the vestigial
hack described in `Note [Optimistic field binder CPR]` is complicated
and causes reboxing. Rather than make the hack worse, this patch
gets rid of it completely in favor of giving deeply unboxed parameters
the Nested CPR property. Example:
```hs
f :: (Int, Int) -> Int
f p = case p of
(x, y) | x == y = x
| otherwise = y
```
Based on `p`'s `idDemandInfo` `1P(1P(L),1P(L))`, we can see that both
fields of `p` will be available unboxed. As a result, we give `p` the
nested CPR property `1(1,1)`. When analysing the `case`, the field
CPRs are transferred to the binders `x` and `y`, respectively, so that
we ultimately give `f` the CPR property.
I took the liberty to do a bit of refactoring:
- I renamed `CprResult` ("Constructed product result result") to plain
`Cpr`.
- I Introduced `FlatConCpr` in addition to (now nested) `ConCpr` and
and according pattern synonym that rewrites flat `ConCpr` to
`FlatConCpr`s, purely for compiler perf reasons.
- Similarly for performance reasons, we now store binders with a
Top signature in a separate `IntSet`,
see `Note [Efficient Top sigs in SigEnv]`.
- I moved a bit of stuff around in `GHC.Core.Opt.WorkWrap.Utils` and
introduced `UnboxingDecision` to replace the `Maybe DataConPatContext`
type we used to return from `wantToUnbox`.
- Since the `Outputable Cpr` instance changed anyway, I removed the
leading `m` which we used to emit for `ConCpr`. It's just noise,
especially now that we may output nested CPRs.
Fixes #19398.
---
compiler/GHC/Core/Opt/CprAnal.hs | 215 ++++--
compiler/GHC/Core/Opt/WorkWrap.hs | 4 +-
compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 672 +++++++++---------
compiler/GHC/Data/Graph/UnVar.hs | 2 +-
compiler/GHC/Types/Cpr.hs | 225 ++++--
compiler/GHC/Types/Id/Make.hs | 4 +-
.../tests/cpranal/sigs/CaseBinderCPR.stderr | 3 +-
testsuite/tests/cpranal/sigs/T19232.stderr | 1 -
testsuite/tests/cpranal/sigs/T19398.hs | 32 +
testsuite/tests/cpranal/sigs/T19398.stderr | 8 +
testsuite/tests/cpranal/sigs/all.T | 3 +-
.../tests/deSugar/should_compile/T2431.stderr | 2 +-
.../tests/numeric/should_compile/T7116.stdout | 8 +-
.../simplCore/should_compile/T13143.stderr | 2 +-
.../simplCore/should_compile/T13543.stderr | 4 +-
.../simplCore/should_compile/T3717.stderr | 2 +-
.../simplCore/should_compile/T4930.stderr | 2 +-
.../simplCore/should_compile/T7360.stderr | 4 +-
.../should_compile/spec-inline.stderr | 4 +-
.../stranal/should_compile/T10694.stderr | 2 +-
.../stranal/sigs/BottomFromInnerLambda.stderr | 2 +-
.../tests/stranal/sigs/DmdAnalGADTs.stderr | 4 +-
.../tests/stranal/sigs/HyperStrUse.stderr | 2 +-
.../tests/stranal/sigs/NewtypeArity.stderr | 4 +-
testsuite/tests/stranal/sigs/T12370.stderr | 4 +-
testsuite/tests/stranal/sigs/T18957.stderr | 2 +-
testsuite/tests/stranal/sigs/T8598.stderr | 2 +-
testsuite/tests/stranal/sigs/UnsatFun.stderr | 4 +-
28 files changed, 710 insertions(+), 513 deletions(-)
create mode 100644 testsuite/tests/cpranal/sigs/T19398.hs
create mode 100644 testsuite/tests/cpranal/sigs/T19398.stderr
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index d8330abe2b03..be3fa732821f 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -21,20 +21,26 @@ import GHC.Core.Seq
import GHC.Utils.Outputable
import GHC.Types.Var.Env
import GHC.Types.Basic
-import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Id.Info
+import GHC.Core.DataCon
+import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram )
import GHC.Core.Type
import GHC.Core.FamInstEnv
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Utils.Misc
+import GHC.Utils.Panic
import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) )
-import GHC.Data.Maybe ( isJust, isNothing )
+import GHC.Data.Graph.UnVar -- for UnVarSet
+import GHC.Data.Maybe ( isNothing )
import Control.Monad ( guard )
import Data.List ( mapAccumL )
+import GHC.Driver.Ppr
+_ = pprTrace -- Tired of commenting out the import all the time
+
{- Note [Constructed Product Result]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The goal of Constructed Product Result analysis is to identify functions that
@@ -177,7 +183,8 @@ cprAnal' env (Lam var body)
| otherwise
= (lam_ty, Lam var body')
where
- env' = extendSigEnvForDemand env var (idDemandInfo var)
+ -- See Note [CPR for binders that will be unboxed]
+ env' = extendSigEnvForArg env var
(body_ty, body') = cprAnal env' body
lam_ty = abstractCprTy body_ty
@@ -185,11 +192,8 @@ cprAnal' env (Case scrut case_bndr ty alts)
= (res_ty, Case scrut' case_bndr ty alts')
where
(scrut_ty, scrut') = cprAnal env scrut
- -- We used to give the case binder the CPR property unconditionally.
- -- See Historic Note [Optimistic case binder CPR]
env' = extendSigEnv env case_bndr (CprSig scrut_ty)
- be_optimistic = assumeOptimisticFieldCpr scrut scrut_ty
- (alt_tys, alts') = mapAndUnzip (cprAnalAlt env' be_optimistic) alts
+ (alt_tys, alts') = mapAndUnzip (cprAnalAlt env' scrut_ty) alts
res_ty = foldl' lubCprType botCprType alt_tys
cprAnal' env (Let (NonRec id rhs) body)
@@ -206,49 +210,28 @@ cprAnal' env (Let (Rec pairs) body)
cprAnalAlt
:: AnalEnv
- -> Bool -- ^ Does Note [Optimistic field binder CPR] apply?
- -> Alt Var -- ^ current alternative
+ -> CprType -- ^ CPR type of the scrutinee
+ -> Alt Var -- ^ current alternative
-> (CprType, Alt Var)
-cprAnalAlt env be_optimistic (Alt con bndrs rhs)
+cprAnalAlt env scrut_ty (Alt con bndrs rhs)
= (rhs_ty, Alt con bndrs rhs')
where
env_alt
- | DataAlt dc <- con, be_optimistic
- -- Optimistically give strictly used field binders the CPR property.
- -- See Note [Optimistic field binder CPR].
- -- What we actually want here is Nested CPR.
- = giveStrictFieldsCpr env dc bndrs
+ | DataAlt dc <- con
+ , let ids = filter isId bndrs
+ , CprType arity cpr <- scrut_ty
+ , ASSERT( arity == 0 ) True
+ = case unpackConFieldsCpr dc cpr of
+ AllFieldsSame field_cpr
+ | let sig = mkCprSig 0 field_cpr
+ -> extendSigEnvAllSame env ids sig
+ ForeachField field_cprs
+ | let sigs = zipWith (mkCprSig . idArity) ids field_cprs
+ -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)
| otherwise
= env
(rhs_ty, rhs') = cprAnal env_alt rhs
-giveStrictFieldsCpr :: AnalEnv -> DataCon -> [Id] -> AnalEnv
--- See Note [Optimistic field binder CPR]
-giveStrictFieldsCpr env dc bs = foldl' do_one_field env (fields_w_dmds dc bs)
- where
- -- 'extendSigEnvForDemand' gives 'id' the CPR property if 'dmd' is strict
- do_one_field env (id, dmd) = extendSigEnvForDemand env id dmd
- fields_w_dmds dc bndrs = -- returns the fields paired with their 'idDemandInfo'
- -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils
- [ (id, applyWhen (isMarkedStrict mark) strictifyDmd (idDemandInfo id))
- | (id, mark) <- filter isId bndrs `zip` dataConRepStrictness dc
- ]
-
--- | Decide whether to optimistically give 'DataAlt' field binders the CPR
--- property based on strictness.
--- Tests (A) and (B) of Note [Optimistic field binder CPR].
-assumeOptimisticFieldCpr :: CoreExpr -> CprType -> Bool
-assumeOptimisticFieldCpr scrut scrut_ty = is_var scrut && case_will_cancel
- where
- -- Test (A): The case will only cancel when 'scrut' has the CPR property.
- case_will_cancel | CprType 0 cpr <- scrut_ty = isJust (asConCpr cpr)
- | otherwise = False
- -- Test (B): Guess whether 'scrut' is a parameter. Surely not if it's not a
- -- variable!
- is_var (Cast e _) = is_var e
- is_var (Var v) = isLocalId v
- is_var _ = False
-
--
-- * CPR transformer
--
@@ -293,7 +276,7 @@ cprFix top_lvl orig_env orig_pairs
orig_virgin = ae_virgin orig_env
init_pairs | orig_virgin = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]
| otherwise = orig_pairs
- init_env = extendSigEnvList orig_env (map fst init_pairs)
+ init_env = extendSigEnvFromIds orig_env (map fst init_pairs)
-- The fixed-point varies the idCprInfo field of the binders and and their
-- entries in the AnalEnv, and terminates if that annotation does not change
@@ -413,35 +396,68 @@ data AnalEnv
-- ^ 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 ])
+-- | An environment storing 'CprSig's for local Ids.
+-- Puts binders with 'topCprSig' in a space-saving 'IntSet'.
+-- See Note [Efficient Top sigs in SigEnv].
+data SigEnv
+ = SE
+ { se_tops :: !UnVarSet
+ -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient.
+ , se_sigs :: !(VarEnv CprSig)
+ -- ^ Ids that have something other than 'topCprSig'.
+ }
+
+instance Outputable SigEnv where
+ ppr (SE { se_tops = tops, se_sigs = sigs })
+ = text "SE" <+> braces (vcat
+ [ text "se_tops =" <+> ppr tops
+ , text "se_sigs =" <+> ppr sigs ])
+
emptyAnalEnv :: FamInstEnvs -> AnalEnv
emptyAnalEnv fam_envs
= AE
- { ae_sigs = emptyVarEnv
+ { ae_sigs = SE emptyUnVarSet emptyVarEnv
, ae_virgin = True
, ae_fam_envs = fam_envs
}
--- | Extend an environment with the CPR sigs attached to the id
-extendSigEnvList :: AnalEnv -> [Id] -> AnalEnv
-extendSigEnvList env ids
- = env { ae_sigs = sigs' }
- where
- sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]
+modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
+modifySigEnv f env = env { ae_sigs = f (ae_sigs env) }
+
+lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
+-- See Note [Efficient Top sigs in SigEnv]
+lookupSigEnv AE{ae_sigs = SE tops sigs} id
+ | id `elemUnVarSet` tops = Just topCprSig
+ | otherwise = lookupVarEnv sigs id
extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
+-- See Note [Efficient Top sigs in SigEnv]
extendSigEnv env id sig
- = env { ae_sigs = extendVarEnv (ae_sigs env) id sig }
+ | isTopCprSig sig
+ = modifySigEnv (\se -> se{se_tops = extendUnVarSet id (se_tops se)}) env
+ | otherwise
+ = modifySigEnv (\se -> se{se_sigs = extendVarEnv (se_sigs se) id sig}) env
-lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
+-- | Extend an environment with the (Id, CPR sig) pairs
+extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
+extendSigEnvList env ids_cprs
+ = foldl' (\env (id, sig) -> extendSigEnv env id sig) env ids_cprs
+
+-- | Extend an environment with the CPR sigs attached to the ids
+extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv
+extendSigEnvFromIds env ids
+ = foldl' (\env id -> extendSigEnv env id (idCprInfo id)) env ids
+
+-- | Extend an environment with the same CPR sig for all ids
+extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv
+extendSigEnvAllSame env ids sig
+ = foldl' (\env id -> extendSigEnv env id sig) env ids
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin env = env { ae_virgin = False }
@@ -451,29 +467,63 @@ nonVirgin env = env { ae_virgin = False }
-- In this case, we can still look at their demand to attach CPR signatures
-- anticipating the unboxing done by worker/wrapper.
-- See Note [CPR for binders that will be unboxed].
-extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv
-extendSigEnvForDemand env id dmd
- | isId id
- , Just (_, DataConPatContext { dcpc_dc = dc })
- <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd
- = extendSigEnv env id (CprSig (conCprType (dataConTag dc)))
- | otherwise
- = env
+extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv
+extendSigEnvForArg env id
+ = extendSigEnv env id (CprSig (argCprType env (idType id) (idDemandInfo id)))
+
+-- | Produces a 'CprType' according to how a strict argument will be unboxed.
+-- Examples:
+--
+-- * A head-strict demand @1L@ on @Int@ would translate to @1@
+-- * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@
+-- * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,
+-- because the unboxing strategy would not unbox the @a@.
+argCprType :: AnalEnv -> Type -> Demand -> CprType
+argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd)
where
+ go ty dmd
+ | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds
+ <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd
+ -- No existentials; see Note [Which types are unboxed?])
+ -- Otherwise we'd need to call dataConRepInstPat here and thread a
+ -- UniqSupply. So argCprType is a bit less aggressive than it could
+ -- be, for the sake of coding convenience.
+ , null (dataConExTyCoVars dc)
+ , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args)
+ = ConCpr (dataConTag dc) (zipWith go arg_tys ds)
+ | otherwise
+ = topCpr
-- Rather than maintaining in AnalEnv whether we are in an INLINEABLE
-- function, we just assume that we aren't. That flag is only relevant
-- to Note [Do not unpack class dictionaries], the few unboxing
-- opportunities on dicts it prohibits are probably irrelevant to CPR.
- has_inlineable_prag = False
+ no_inlineable_prag = 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 [Efficient Top sigs in SigEnv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's pretty common for binders in the SigEnv to have a 'topCprSig'.
+Wide records with 100 fields like in T9675 even will generate code where the
+majority of binders has Top signature. To save some allocations, we store
+those binders with a Top signature in a separate UnVarSet (which is an IntSet
+with a convenient Var-tailored API).
+
+Why store top signatures at all in the SigEnv? After all, when 'cprTransform'
+encounters a locally-bound Id without an entry in the SigEnv, it should behave
+as if that binder has a Top signature!
+Well, the problem is when case binders should have a Top signatures. They always
+have an unfolding and thus look to 'cprTransform' as if they bind a data
+structure, Note [CPR for data structures], and thus would always have the CPR
+property. So we need some mechanism to separate data structures from case
+binders with a Top signature, and the UnVarSet provides that in the least
+convoluted way I can think of.
+
Note [CPR for binders that will be unboxed]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a lambda-bound variable will be unboxed by worker/wrapper (so it must be
@@ -496,21 +546,37 @@ 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.
-This is all done in 'extendSigEnvForDemand'.
+This is all done in 'extendSigEnvForArg'.
Note that
- * We only want to do this for something that definitely unboxes as per
- 'wantToUnbox', else we may get over-optimistic CPR results e.g.
- (from \x -> x!).
+ * Whether or not something unboxes is decided by 'wantToUnbox', else we may
+ get over-optimistic CPR results (e.g., from \(x :: a) -> x!).
+
+ * If the demand unboxes deeply, we can give the binder a /nested/ CPR
+ property, e.g.
+
+ g :: (Int, Int) -> Int
+ g p = case p of
+ (x, y) | x < 0 -> 0
+ | otherwise -> x
+
+ `x` should have the CPR property because it will be unboxed. We do so
+ by giving `p` the Nested CPR property `1(1,)`, indicating that we not only
+ have `p` available unboxed, but also its field `x`. Analysis of the Case
+ will then transfer the CPR property to `x`.
- * This also (approximately) applies to DataAlt field binders;
- See Note [Optimistic field binder CPR].
+ Before we were able to express Nested CPR, we used to guess which field
+ binders should get the CPR property.
+ See Historic Note [Optimistic field binder CPR].
* See Note [CPR examples]
-Note [Optimistic field binder CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Historic Note [Optimistic field binder CPR]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This Note describes how we used to guess whether fields have the CPR property
+before we were able to express Nested CPR for arguments.
+
Consider
data T a = MkT a
@@ -531,9 +597,6 @@ Lacking Nested CPR, we have to guess a bit, by looking for
(B) A variable scrutinee. Otherwise surely it can't be a parameter.
(C) Strict demand on the field binder `y` (or it binds a strict field)
-(A) and (B) are tested in 'assumeOptimisticFieldCpr',
-(C) in 'giveStrictFieldsCpr' via 'extendSigEnvForDemand'.
-
While (A) is a necessary condition to give a field the CPR property, there are
ways in which (B) and (C) are too lax, leading to unsound analysis results and
thus reboxing in the wrapper:
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index a4444d995729..030cb2ac8aea 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -602,7 +602,7 @@ See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.
---------------------
-splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr
+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr
-> UniqSM [(Id, CoreExpr)]
splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
| isRecordSelector fn_id -- See Note [No worker/wrapper for record selectors]
@@ -638,7 +638,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity
- -> CoreExpr -> Unique -> Divergence -> CprResult
+ -> CoreExpr -> Unique -> Divergence -> Cpr
-> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)
-> [(Id, CoreExpr)]
mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 0a7ef0f3a5b8..5223e668173a 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -8,7 +8,7 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser
module GHC.Core.Opt.WorkWrap.Utils
( mkWwBodies, mkWWstr, mkWorkerArgs
- , DataConPatContext(..), splitArgType_maybe, wantToUnbox
+ , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox
, findTypeShape
, isWorkerSmallEnough
)
@@ -135,7 +135,7 @@ mkWwBodies :: DynFlags
-- See Note [Freshen WW arguments]
-> Id -- The original function
-> [Demand] -- Strictness of original function
- -> CprResult -- Info about function result
+ -> Cpr -- Info about function result
-> UniqSM (Maybe WwResult)
-- wrap_fn_args E = \x y -> E
@@ -511,43 +511,161 @@ To avoid this:
Another tricky case was when f :: forall a. a -> forall a. a->a
(i.e. with shadowing), and then the worker used the same 'a' twice.
+-}
+{-
************************************************************************
* *
-\subsection{Strictness stuff}
+\subsection{Unboxing Decision for Strictness and CPR}
* *
************************************************************************
-}
-mkWWstr :: DynFlags
- -> FamInstEnvs
- -> Bool -- True <=> INLINEABLE pragma on this function defn
- -- See Note [Do not unpack class dictionaries]
- -> [Var] -- Wrapper args; have their demand info on them
- -- *Includes type variables*
- -> UniqSM (Bool, -- Is this useful
- [Var], -- Worker args
- CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
- -- and without its lambdas
- -- This fn adds the unboxing
+-- | The information needed to build a pattern for a DataCon to be unboxed.
+-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via
+-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype
+-- wrappers.
+--
+-- If we get @DataConPatContext dc tys co@ for some type @ty@
+-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then
+--
+-- * @dc @exs flds :: T tys@
+-- * @co :: T tys ~ ty@
+data DataConPatContext
+ = DataConPatContext
+ { dcpc_dc :: !DataCon
+ , dcpc_tc_args :: ![Type]
+ , dcpc_co :: !Coercion
+ }
- CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
- -- and lacking its lambdas.
- -- This fn does the reboxing
-mkWWstr dflags fam_envs has_inlineable_prag args
- = go args
+-- | If @splitArgType_maybe ty = Just (dc, tys, co)@
+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
+-- and @co :: ty ~ tc tys@
+-- where underscore prefixes are holes, e.g. yet unspecified.
+--
+-- See Note [Which types are unboxed?].
+splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext
+splitArgType_maybe fam_envs ty
+ | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+ `orElse` (mkRepReflCo ty, ty)
+ , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+ , Just con <- tyConSingleAlgDataCon_maybe tc
+ = Just DataConPatContext { dcpc_dc = con
+ , dcpc_tc_args = tc_args
+ , dcpc_co = co }
+splitArgType_maybe _ _ = Nothing
+
+-- | If @splitResultType_maybe n ty = Just (dc, tys, co)@
+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
+-- and @co :: ty ~ tc tys@
+-- where underscore prefixes are holes, e.g. yet unspecified.
+-- @dc@ is the @n@th data constructor of @tc@.
+--
+-- See Note [Which types are unboxed?].
+splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext
+splitResultType_maybe fam_envs con_tag ty
+ | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+ `orElse` (mkRepReflCo ty, ty)
+ , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+ , isDataTyCon tc -- NB: rules out unboxed sums and pairs!
+ , let cons = tyConDataCons tc
+ , cons `lengthAtLeast` con_tag -- This might not be true if we import the
+ -- type constructor via a .hs-boot file (#8743)
+ , let con = cons `getNth` (con_tag - fIRST_TAG)
+ , null (dataConExTyCoVars con) -- no existentials;
+ -- See Note [Which types are unboxed?]
+ -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt
+ -- where we also check this.
+ , all isLinear (dataConInstArgTys con tc_args)
+ -- Deactivates CPR worker/wrapper splits on constructors with non-linear
+ -- arguments, for the moment, because they require unboxed tuple with variable
+ -- multiplicity fields.
+ = Just DataConPatContext { dcpc_dc = con
+ , dcpc_tc_args = tc_args
+ , dcpc_co = co }
+splitResultType_maybe _ _ _ = Nothing
+
+isLinear :: Scaled a -> Bool
+isLinear (Scaled w _ ) =
+ case w of
+ One -> True
+ _ -> False
+
+-- | Describes the outer shape of an argument to be unboxed or left as-is
+-- Depending on how @s@ is instantiated (e.g., 'Demand').
+data UnboxingDecision s
+ = StopUnboxing
+ -- ^ We ran out of strictness info. Leave untouched.
+ | Unbox !DataConPatContext [s]
+ -- ^ The argument is used strictly or the returned product was constructed, so
+ -- unbox it.
+ -- The 'DataConPatContext' carries the bits necessary for
+ -- instantiation with 'dataConRepInstPat'.
+ -- The @[s]@ carries the bits of information with which we can continue
+ -- unboxing, e.g. @s@ will be 'Demand'.
+
+wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand
+-- See Note [Which types are unboxed?]
+wantToUnbox fam_envs has_inlineable_prag ty dmd =
+ case splitArgType_maybe fam_envs ty of
+ Just dcpc@DataConPatContext{ dcpc_dc = dc }
+ | isStrUsedDmd dmd
+ , let arity = dataConRepArity dc
+ -- See Note [Unpacking arguments with product and polymorphic demands]
+ , Just cs <- split_prod_dmd_arity dmd arity
+ -- See Note [Do not unpack class dictionaries]
+ , not (has_inlineable_prag && isClassPred ty)
+ -- See Note [mkWWstr and unsafeCoerce]
+ , cs `lengthIs` arity
+ -- See Note [Add demands for strict constructors]
+ , let cs' = addDataConStrictness dc cs
+ -> Unbox dcpc cs'
+ _ -> StopUnboxing
where
- go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
+ split_prod_dmd_arity dmd arity
+ -- For seqDmd, it should behave like <S(AAAA)>, for some
+ -- suitable arity
+ | isSeqDmd dmd = Just (replicate arity absDmd)
+ | _ :* Prod ds <- dmd = Just ds
+ | otherwise = Nothing
- go [] = return (False, [], nop_fn, nop_fn)
- go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
- ; (useful2, args2, wrap_fn2, work_fn2) <- go args
- ; return ( useful1 || useful2
- , args1 ++ args2
- , wrap_fn1 . wrap_fn2
- , work_fn1 . work_fn2) }
+{- Note [Which types are unboxed?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Worker/wrapper will unbox
+
+ 1. A strict data type argument, that
+ * is an algebraic data type (not a newtype)
+ * has a single constructor (thus is a "product")
+ * that may bind existentials
+ We can transform
+ > f (D @ex a b) = e
+ to
+ > $wf @ex a b = e
+ via 'mkWWstr'.
+
+ 2. The constructed result of a function, if
+ * its type is an algebraic data type (not a newtype)
+ * (might have multiple constructors, in contrast to (1))
+ * the applied data constructor *does not* bind existentials
+ We can transform
+ > f x y = let ... in D a b
+ to
+ > $wf x y = let ... in (# a, b #)
+ via 'mkWWcpr'.
+
+ NB: We don't allow existentials for CPR W/W, because we don't have unboxed
+ dependent tuples (yet?). Otherwise, we could transform
+ > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)
+ to
+ > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)
+
+The respective tests are in 'splitArgType_maybe' and
+'splitResultType_maybe', respectively.
+
+Note that the data constructor /can/ have evidence arguments: equality
+constraints, type classes etc. So it can be GADT. These evidence
+arguments are simply value arguments, and should not get in the way.
-{-
Note [Unpacking arguments with product and polymorphic demands]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The argument is unpacked in a case if it has a product type and has a
@@ -574,8 +692,192 @@ to unbox its second argument. This actually happened in GHC's onwn
source code, in Packages.applyPackageFlag, which ended up un-boxing
the enormous DynFlags tuple, and being strict in the
as-yet-un-filled-in unitState files.
+
+Note [Do not unpack class dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+ f :: Ord a => [a] -> Int -> a
+ {-# INLINABLE f #-}
+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
+(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
+which can still be specialised by the type-class specialiser, something like
+ fw :: Ord a => [a] -> Int# -> a
+
+BUT if f is strict in the Ord dictionary, we might unpack it, to get
+ fw :: (a->a->Bool) -> [a] -> Int# -> a
+and the type-class specialiser can't specialise that. An example is #6056.
+
+But in any other situation a dictionary is just an ordinary value,
+and can be unpacked. So we track the INLINABLE pragma, and switch
+off the unpacking in mkWWstr_one (see the isClassPred test).
+
+Historical note: #14955 describes how I got this fix wrong the first time.
+
+Note [mkWWstr and unsafeCoerce]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+By using unsafeCoerce, it is possible to make the number of demands fail to
+match the number of constructor arguments; this happened in #8037.
+If so, the worker/wrapper split doesn't work right and we get a Core Lint
+bug. The fix here is simply to decline to do w/w if that happens.
+
+Note [Add demands for strict constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this program (due to Roman):
+
+ data X a = X !a
+
+ foo :: X Int -> Int -> Int
+ foo (X a) n = go 0
+ where
+ go i | i < n = a + go (i+1)
+ | otherwise = 0
+
+We want the worker for 'foo' too look like this:
+
+ $wfoo :: Int# -> Int# -> Int#
+
+with the first argument unboxed, so that it is not eval'd each time
+around the 'go' loop (which would otherwise happen, since 'foo' is not
+strict in 'a'). It is sound for the wrapper to pass an unboxed arg
+because X is strict, so its argument must be evaluated. And if we
+*don't* pass an unboxed argument, we can't even repair it by adding a
+`seq` thus:
+
+ foo (X a) n = a `seq` go 0
+
+because the seq is discarded (very early) since X is strict!
+
+So here's what we do
+
+* We leave the demand-analysis alone. The demand on 'a' in the
+ definition of 'foo' is <L, U(U)>; the strictness info is Lazy
+ because foo's body may or may not evaluate 'a'; but the usage info
+ says that 'a' is unpacked and its content is used.
+
+* During worker/wrapper, if we unpack a strict constructor (as we do
+ for 'foo'), we use 'addDataConStrictness' to bump up the strictness on
+ the strict arguments of the data constructor.
+
+* That in turn means that, if the usage info supports doing so
+ (i.e. splitProdDmd_maybe returns Just), we will unpack that argument
+ -- even though the original demand (e.g. on 'a') was lazy.
+
+* What does "bump up the strictness" mean? Just add a head-strict
+ demand to the strictness! Even for a demand like <L,A> we can
+ safely turn it into <S,A>; remember case (1) of
+ Note [How to do the worker/wrapper split].
+
+The net effect is that the w/w transformation is more aggressive about
+unpacking the strict arguments of a data constructor, when that
+eagerness is supported by the usage info.
+
+There is the usual danger of reboxing, which as usual we ignore. But
+if X is monomorphic, and has an UNPACK pragma, then this optimisation
+is even more important. We don't want the wrapper to rebox an unboxed
+argument, and pass an Int to $wfoo!
+
+This works in nested situations like
+
+ data family Bar a
+ data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
+ newtype instance Bar Int = Bar Int
+
+ foo :: Bar ((Int, Int), Int) -> Int -> Int
+ foo f k = case f of BarPair x y ->
+ case burble of
+ True -> case x of
+ BarPair p q -> ...
+ False -> ...
+
+The extra eagerness lets us produce a worker of type:
+ $wfoo :: Int# -> Int# -> Int# -> Int -> Int
+ $wfoo p# q# y# = ...
+
+even though the `case x` is only lazily evaluated.
+
+--------- Historical note ------------
+We used to add data-con strictness demands when demand analysing case
+expression. However, it was noticed in #15696 that this misses some cases. For
+instance, consider the program (from T10482)
+
+ data family Bar a
+ data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
+ newtype instance Bar Int = Bar Int
+
+ foo :: Bar ((Int, Int), Int) -> Int -> Int
+ foo f k =
+ case f of
+ BarPair x y -> case burble of
+ True -> case x of
+ BarPair p q -> ...
+ False -> ...
+
+We really should be able to assume that `p` is already evaluated since it came
+from a strict field of BarPair. This strictness would allow us to produce a
+worker of type:
+
+ $wfoo :: Int# -> Int# -> Int# -> Int -> Int
+ $wfoo p# q# y# = ...
+
+even though the `case x` is only lazily evaluated
+
+Indeed before we fixed #15696 this would happen since we would float the inner
+`case x` through the `case burble` to get:
+
+ foo f k =
+ case f of
+ BarPair x y -> case x of
+ BarPair p q -> case burble of
+ True -> ...
+ False -> ...
+
+However, after fixing #15696 this could no longer happen (for the reasons
+discussed in ticket:15696#comment:76). This means that the demand placed on `f`
+would then be significantly weaker (since the False branch of the case on
+`burble` is not strict in `p` or `q`).
+
+Consequently, we now instead account for data-con strictness in mkWWstr_one,
+applying the strictness demands to the final result of DmdAnal. The result is
+that we get the strict demand signature we wanted even if we can't float
+the case on `x` up through the case on `burble`.
-}
+{-
+************************************************************************
+* *
+\subsection{Strictness stuff}
+* *
+************************************************************************
+-}
+
+mkWWstr :: DynFlags
+ -> FamInstEnvs
+ -> Bool -- True <=> INLINEABLE pragma on this function defn
+ -- See Note [Do not unpack class dictionaries]
+ -> [Var] -- Wrapper args; have their demand info on them
+ -- *Includes type variables*
+ -> UniqSM (Bool, -- Is this useful
+ [Var], -- Worker args
+ CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
+ -- and without its lambdas
+ -- This fn adds the unboxing
+
+ CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
+ -- and lacking its lambdas.
+ -- This fn does the reboxing
+mkWWstr dflags fam_envs has_inlineable_prag args
+ = go args
+ where
+ go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
+
+ go [] = return (False, [], nop_fn, nop_fn)
+ go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
+ ; (useful2, args2, wrap_fn2, work_fn2) <- go args
+ ; return ( useful1 || useful2
+ , args1 ++ args2
+ , wrap_fn1 . wrap_fn2
+ , work_fn1 . work_fn2) }
+
----------------------
-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
-- * wrap_fn assumes wrap_arg is in scope,
@@ -599,38 +901,15 @@ mkWWstr_one dflags fam_envs has_inlineable_prag arg
-- (that's what mk_absent_let does)
= return (True, [], nop_fn, work_fn)
- | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd
- = unbox_one dflags fam_envs arg cs acdc
+ | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd
+ = unbox_one dflags fam_envs arg cs dcpc
| otherwise -- Other cases
- = return (False, [arg], nop_fn, nop_fn)
-
- where
- arg_ty = idType arg
- dmd = idDemandInfo arg
-
-wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConPatContext)
--- See Note [Which types are unboxed?]
-wantToUnbox fam_envs has_inlineable_prag ty dmd =
- case splitArgType_maybe fam_envs ty of
- Just dcpc@DataConPatContext{ dcpc_dc = dc }
- | isStrUsedDmd dmd
- , let arity = dataConRepArity dc
- -- See Note [Unpacking arguments with product and polymorphic demands]
- , Just cs <- split_prod_dmd_arity dmd arity
- -- See Note [Do not unpack class dictionaries]
- , not (has_inlineable_prag && isClassPred ty)
- -- See Note [mkWWstr and unsafeCoerce]
- , cs `lengthIs` arity
- -> Just (cs, dcpc)
- _ -> Nothing
+ = return (False, [arg], nop_fn, nop_fn)
+
where
- split_prod_dmd_arity dmd arity
- -- For seqDmd, it should behave like <S(AAAA)>, for some
- -- suitable arity
- | isSeqDmd dmd = Just (replicate arity absDmd)
- | _ :* Prod ds <- dmd = Just ds
- | otherwise = Nothing
+ arg_ty = idType arg
+ dmd = idDemandInfo arg
unbox_one :: DynFlags -> FamInstEnvs -> Var
-> [Demand]
@@ -643,9 +922,7 @@ unbox_one dflags fam_envs arg cs
; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc
(ex_tvs', arg_ids) =
dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args
- -- See Note [Add demands for strict constructors]
- cs' = addDataConStrictness dc cs
- arg_ids' = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs'
+ arg_ids' = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs
unbox_fn = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq
dc (ex_tvs' ++ arg_ids')
arg_no_unf = zapStableUnfolding arg
@@ -663,6 +940,10 @@ nop_fn body = body
addDataConStrictness :: DataCon -> [Demand] -> [Demand]
-- See Note [Add demands for strict constructors]
+addDataConStrictness con ds
+ | Nothing <- dataConWrapId_maybe con
+ -- DataCon worker=wrapper. Implies no strict fields, so nothing to do
+ = ds
addDataConStrictness con ds
= zipWithEqual "addDataConStrictness" add ds strs
where
@@ -737,135 +1018,6 @@ The re-boxing code won't go away unless error_fn gets a wrapper too.
[We don't do reboxing now, but in general it's better to pass an
unboxed thing to f, and have it reboxed in the error cases....]
-Note [Add demands for strict constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this program (due to Roman):
-
- data X a = X !a
-
- foo :: X Int -> Int -> Int
- foo (X a) n = go 0
- where
- go i | i < n = a + go (i+1)
- | otherwise = 0
-
-We want the worker for 'foo' too look like this:
-
- $wfoo :: Int# -> Int# -> Int#
-
-with the first argument unboxed, so that it is not eval'd each time
-around the 'go' loop (which would otherwise happen, since 'foo' is not
-strict in 'a'). It is sound for the wrapper to pass an unboxed arg
-because X is strict, so its argument must be evaluated. And if we
-*don't* pass an unboxed argument, we can't even repair it by adding a
-`seq` thus:
-
- foo (X a) n = a `seq` go 0
-
-because the seq is discarded (very early) since X is strict!
-
-So here's what we do
-
-* We leave the demand-analysis alone. The demand on 'a' in the
- definition of 'foo' is <L, U(U)>; the strictness info is Lazy
- because foo's body may or may not evaluate 'a'; but the usage info
- says that 'a' is unpacked and its content is used.
-
-* During worker/wrapper, if we unpack a strict constructor (as we do
- for 'foo'), we use 'addDataConStrictness' to bump up the strictness on
- the strict arguments of the data constructor.
-
-* That in turn means that, if the usage info supports doing so
- (i.e. splitProdDmd_maybe returns Just), we will unpack that argument
- -- even though the original demand (e.g. on 'a') was lazy.
-
-* What does "bump up the strictness" mean? Just add a head-strict
- demand to the strictness! Even for a demand like <L,A> we can
- safely turn it into <S,A>; remember case (1) of
- Note [How to do the worker/wrapper split].
-
-The net effect is that the w/w transformation is more aggressive about
-unpacking the strict arguments of a data constructor, when that
-eagerness is supported by the usage info.
-
-There is the usual danger of reboxing, which as usual we ignore. But
-if X is monomorphic, and has an UNPACK pragma, then this optimisation
-is even more important. We don't want the wrapper to rebox an unboxed
-argument, and pass an Int to $wfoo!
-
-This works in nested situations like
-
- data family Bar a
- data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
- newtype instance Bar Int = Bar Int
-
- foo :: Bar ((Int, Int), Int) -> Int -> Int
- foo f k = case f of BarPair x y ->
- case burble of
- True -> case x of
- BarPair p q -> ...
- False -> ...
-
-The extra eagerness lets us produce a worker of type:
- $wfoo :: Int# -> Int# -> Int# -> Int -> Int
- $wfoo p# q# y# = ...
-
-even though the `case x` is only lazily evaluated.
-
---------- Historical note ------------
-We used to add data-con strictness demands when demand analysing case
-expression. However, it was noticed in #15696 that this misses some cases. For
-instance, consider the program (from T10482)
-
- data family Bar a
- data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
- newtype instance Bar Int = Bar Int
-
- foo :: Bar ((Int, Int), Int) -> Int -> Int
- foo f k =
- case f of
- BarPair x y -> case burble of
- True -> case x of
- BarPair p q -> ...
- False -> ...
-
-We really should be able to assume that `p` is already evaluated since it came
-from a strict field of BarPair. This strictness would allow us to produce a
-worker of type:
-
- $wfoo :: Int# -> Int# -> Int# -> Int -> Int
- $wfoo p# q# y# = ...
-
-even though the `case x` is only lazily evaluated
-
-Indeed before we fixed #15696 this would happen since we would float the inner
-`case x` through the `case burble` to get:
-
- foo f k =
- case f of
- BarPair x y -> case x of
- BarPair p q -> case burble of
- True -> ...
- False -> ...
-
-However, after fixing #15696 this could no longer happen (for the reasons
-discussed in ticket:15696#comment:76). This means that the demand placed on `f`
-would then be significantly weaker (since the False branch of the case on
-`burble` is not strict in `p` or `q`).
-
-Consequently, we now instead account for data-con strictness in mkWWstr_one,
-applying the strictness demands to the final result of DmdAnal. The result is
-that we get the strict demand signature we wanted even if we can't float
-the case on `x` up through the case on `burble`.
-
-
-Note [mkWWstr and unsafeCoerce]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-By using unsafeCoerce, it is possible to make the number of demands fail to
-match the number of constructor arguments; this happened in #8037.
-If so, the worker/wrapper split doesn't work right and we get a Core Lint
-bug. The fix here is simply to decline to do w/w if that happens.
-
Note [Record evaluated-ness in worker/wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
@@ -913,97 +1065,8 @@ to record that the relevant binder is evaluated.
Type scrutiny that is specific to demand analysis
* *
************************************************************************
-
-Note [Do not unpack class dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have
- f :: Ord a => [a] -> Int -> a
- {-# INLINABLE f #-}
-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
-(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
-which can still be specialised by the type-class specialiser, something like
- fw :: Ord a => [a] -> Int# -> a
-
-BUT if f is strict in the Ord dictionary, we might unpack it, to get
- fw :: (a->a->Bool) -> [a] -> Int# -> a
-and the type-class specialiser can't specialise that. An example is #6056.
-
-But in any other situation a dictionary is just an ordinary value,
-and can be unpacked. So we track the INLINABLE pragma, and switch
-off the unpacking in mkWWstr_one (see the isClassPred test).
-
-Historical note: #14955 describes how I got this fix wrong the first time.
-}
--- | The result of 'splitArgType_maybe' and 'splitResultType_maybe'.
---
--- Both splits
--- * Take a type `ty`
--- * Succeed with (DataConPatContext dc tys co)
--- iff co :: T tys ~ ty
--- and `dc` is the appropriate DataCon of `T`
--- and `T` is suitable for the kind of split
--- (differs for strictness and CPR, see Note [Which types are unboxed?])
-data DataConPatContext
- = DataConPatContext
- { dcpc_dc :: !DataCon
- , dcpc_tc_args :: ![Type]
- , dcpc_co :: !Coercion
- }
-
--- | If @splitArgType_maybe ty = Just (dc, tys, co)@
--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
--- and @co :: ty ~ tc tys@
--- where underscore prefixes are holes, e.g. yet unspecified.
---
--- See Note [Which types are unboxed?].
-splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext
-splitArgType_maybe fam_envs ty
- | let (co, ty1) = topNormaliseType_maybe fam_envs ty
- `orElse` (mkRepReflCo ty, ty)
- , Just (tc, tc_args) <- splitTyConApp_maybe ty1
- , Just con <- tyConSingleAlgDataCon_maybe tc
- = Just DataConPatContext { dcpc_dc = con
- , dcpc_tc_args = tc_args
- , dcpc_co = co }
-splitArgType_maybe _ _ = Nothing
-
--- | If @splitResultType_maybe n ty = Just (dc, tys, co)@
--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
--- and @co :: ty ~ tc tys@
--- where underscore prefixes are holes, e.g. yet unspecified.
--- @dc@ is the @n@th data constructor of @tc@.
---
--- See Note [Which types are unboxed?].
-splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext
-splitResultType_maybe fam_envs con_tag ty
- | let (co, ty1) = topNormaliseType_maybe fam_envs ty
- `orElse` (mkRepReflCo ty, ty)
- , Just (tc, tc_args) <- splitTyConApp_maybe ty1
- , isDataTyCon tc -- NB: rules out unboxed sums and pairs!
- , let cons = tyConDataCons tc
- , cons `lengthAtLeast` con_tag -- This might not be true if we import the
- -- type constructor via a .hs-boot file (#8743)
- , let con = cons `getNth` (con_tag - fIRST_TAG)
- , null (dataConExTyCoVars con) -- no existentials;
- -- See Note [Which types are unboxed?]
- -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt
- -- where we also check this.
- , all isLinear (dataConInstArgTys con tc_args)
- -- Deactivates CPR worker/wrapper splits on constructors with non-linear
- -- arguments, for the moment, because they require unboxed tuple with variable
- -- multiplicity fields.
- = Just DataConPatContext { dcpc_dc = con
- , dcpc_tc_args = tc_args
- , dcpc_co = co }
-splitResultType_maybe _ _ _ = Nothing
-
-isLinear :: Scaled a -> Bool
-isLinear (Scaled w _ ) =
- case w of
- One -> True
- _ -> False
-
findTypeShape :: FamInstEnvs -> Type -> TypeShape
-- Uncover the arrow and product shape of a type
-- The data type TypeShape is defined in GHC.Types.Demand
@@ -1062,43 +1125,7 @@ dubiousDataConInstArgTys dc tc_args = arg_tys
subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs
arg_tys = map (substTy subst . scaledThing) (dataConRepArgTys dc)
-{- Note [Which types are unboxed?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Worker/wrapper will unbox
-
- 1. A strict data type argument, that
- * is an algebraic data type (not a newtype)
- * has a single constructor (thus is a "product")
- * that may bind existentials
- We can transform
- > f (D @ex a b) = e
- to
- > $wf @ex a b = e
- via 'mkWWstr'.
-
- 2. The constructed result of a function, if
- * its type is an algebraic data type (not a newtype)
- * (might have multiple constructors, in contrast to (1))
- * the applied data constructor *does not* bind existentials
- We can transform
- > f x y = let ... in D a b
- to
- > $wf x y = let ... in (# a, b #)
- via 'mkWWcpr'.
-
- NB: We don't allow existentials for CPR W/W, because we don't have unboxed
- dependent tuples (yet?). Otherwise, we could transform
- > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)
- to
- > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)
-
-The respective tests are in 'splitArgType_maybe' and
-'splitResultType_maybe', respectively.
-
-Note that the data constructor /can/ have evidence arguments: equality
-constraints, type classes etc. So it can be GADT. These evidence
-arguments are simply value arguments, and should not get in the way.
-
+{-
************************************************************************
* *
\subsection{CPR stuff}
@@ -1118,7 +1145,7 @@ left-to-right traversal of the result structure.
mkWWcpr :: Bool
-> FamInstEnvs
-> Type -- function body type
- -> CprResult -- CPR analysis results
+ -> Cpr -- CPR analysis results
-> UniqSM (Bool, -- Is w/w'ing useful?
CoreExpr -> CoreExpr, -- New wrapper
CoreExpr -> CoreExpr, -- New worker
@@ -1131,12 +1158,13 @@ mkWWcpr opt_CprAnal fam_envs body_ty cpr
| otherwise
= case asConCpr cpr of
Nothing -> return (False, id, id, body_ty) -- No CPR info
- Just con_tag | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty
- -> mkWWcpr_help dcpc
- | otherwise
- -- See Note [non-algebraic or open body type warning]
- -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
- return (False, id, id, body_ty)
+ Just (con_tag, _cprs)
+ | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty
+ -> mkWWcpr_help dcpc
+ | otherwise
+ -- See Note [non-algebraic or open body type warning]
+ -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
+ return (False, id, id, body_ty)
mkWWcpr_help :: DataConPatContext
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs
index 05bafe98bc72..5bfc23eef6e5 100644
--- a/compiler/GHC/Data/Graph/UnVar.hs
+++ b/compiler/GHC/Data/Graph/UnVar.hs
@@ -17,7 +17,7 @@ equal to g, but twice as expensive and large.
module GHC.Data.Graph.UnVar
( UnVarSet
, emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
- , delUnVarSet
+ , extendUnVarSet, delUnVarSet
, elemUnVarSet, isEmptyUnVarSet
, UnVarGraph
, emptyUnVarGraph
diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs
index a884091cef75..29b28d23e24c 100644
--- a/compiler/GHC/Types/Cpr.hs
+++ b/compiler/GHC/Types/Cpr.hs
@@ -1,61 +1,92 @@
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
--- | Types for the Constructed Product Result lattice. "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+-- | Types for the Constructed Product Result lattice.
+-- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"
-- are its primary customers via 'GHC.Types.Id.idCprInfo'.
module GHC.Types.Cpr (
- CprResult, topCpr, botCpr, conCpr, asConCpr,
- CprType (..), topCprType, botCprType, conCprType,
- lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,
- CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig
+ Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,
+ CprType (..), topCprType, botCprType, flatConCprType,
+ lubCprType, applyCprTy, abstractCprTy, trimCprTy,
+ UnpackConFieldsResult (..), unpackConFieldsCpr,
+ CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig
) where
import GHC.Prelude
+import GHC.Core.DataCon
import GHC.Types.Basic
-import GHC.Utils.Outputable
import GHC.Utils.Binary
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
--
--- * CprResult
+-- * Cpr
--
--- | 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
+data Cpr
+ = BotCpr
+ | ConCpr_ !ConTag ![Cpr]
+ -- ^ The number of field Cprs equals 'dataConRepArity'.
+ -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern
+ -- synonym 'ConCpr'.
+ | FlatConCpr !ConTag
+ | TopCpr
+ deriving Eq
+
+pattern ConCpr :: ConTag -> [Cpr] -> Cpr
+pattern ConCpr t cs <- ConCpr_ t cs where
+ ConCpr t cs
+ | all (== TopCpr) cs = FlatConCpr t
+ | otherwise = ConCpr_ t cs
+{-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-}
+
+viewConTag :: Cpr -> Maybe ConTag
+viewConTag (FlatConCpr t) = Just t
+viewConTag (ConCpr t _) = Just t
+viewConTag _ = Nothing
+{-# INLINE viewConTag #-}
+
+lubCpr :: Cpr -> Cpr -> Cpr
+lubCpr BotCpr cpr = cpr
+lubCpr cpr BotCpr = cpr
+lubCpr (FlatConCpr t1) (viewConTag -> Just t2)
+ | t1 == t2 = FlatConCpr t1
+lubCpr (viewConTag -> Just t1) (FlatConCpr t2)
+ | t1 == t2 = FlatConCpr t2
+lubCpr (ConCpr t1 cs1) (ConCpr t2 cs2)
+ | t1 == t2 = ConCpr t1 (lubFieldCprs cs1 cs2)
+lubCpr _ _ = TopCpr
+
+lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
+lubFieldCprs as bs
+ | as `equalLength` bs = zipWith lubCpr as bs
+ | otherwise = []
+
+topCpr :: Cpr
+topCpr = TopCpr
+
+botCpr :: Cpr
+botCpr = BotCpr
+
+flatConCpr :: ConTag -> Cpr
+flatConCpr t = FlatConCpr t
+
+trimCpr :: Cpr -> Cpr
+trimCpr BotCpr = botCpr
+trimCpr _ = topCpr
+
+asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
+asConCpr (ConCpr t cs) = Just (t, cs)
+asConCpr (FlatConCpr t) = Just (t, [])
+asConCpr TopCpr = Nothing
+asConCpr BotCpr = Nothing
+
+seqCpr :: Cpr -> ()
+seqCpr (ConCpr _ cs) = foldr (seq . seqCpr) () cs
+seqCpr _ = ()
--
-- * CprType
@@ -64,10 +95,10 @@ asConCpr BotCPR = Nothing
-- | 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
+ { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression
+ -- eats before returning the 'ct_cpr'
+ , ct_cpr :: !Cpr -- ^ 'Cpr' eventually unleashed when applied to
+ -- 'ct_arty' arguments
}
instance Eq CprType where
@@ -78,10 +109,10 @@ 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
+botCprType = CprType 0 botCpr
-conCprType :: ConTag -> CprType
-conCprType con_tag = CprType 0 (conCpr con_tag)
+flatConCprType :: ConTag -> CprType
+flatConCprType con_tag = CprType { ct_arty = 0, ct_cpr = flatConCpr con_tag }
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)
@@ -104,14 +135,31 @@ 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 result of 'unpackConFieldsCpr'.
+data UnpackConFieldsResult
+ = AllFieldsSame !Cpr
+ | ForeachField ![Cpr]
+
+-- | Unpacks a 'ConCpr'-shaped 'Cpr' and returns the field 'Cpr's wrapped in a
+-- 'ForeachField'. Otherwise, it returns 'AllFieldsSame' with the appropriate
+-- 'Cpr' to assume for each field.
+--
+-- The use of 'UnpackConFieldsResult' allows O(1) space for the common,
+-- non-'ConCpr' case.
+unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
+unpackConFieldsCpr dc (ConCpr t cs)
+ | t == dataConTag dc, cs `lengthIs` dataConRepArity dc
+ = ForeachField cs
+unpackConFieldsCpr _ BotCpr = AllFieldsSame BotCpr
+unpackConFieldsCpr _ _ = AllFieldsSame TopCpr
+{-# INLINE unpackConFieldsCpr #-}
+
+seqCprTy :: CprType -> ()
+seqCprTy (CprType _ cpr) = seqCpr cpr
+
-- | The arity of the wrapped 'CprType' is the arity at which it is safe
-- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand"
newtype CprSig = CprSig { getCprSig :: CprType }
@@ -121,21 +169,40 @@ newtype CprSig = CprSig { getCprSig :: CprType }
-- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in
-- "GHC.Types.Demand"
mkCprSigForArity :: Arity -> CprType -> CprSig
-mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty)
+mkCprSigForArity arty ty@(CprType n cpr)
+ | arty /= n = topCprSig
+ -- Trim on arity mismatch
+ | ConCpr t _ <- cpr = CprSig (CprType n (flatConCpr t))
+ -- Flatten nested CPR info, we don't exploit it (yet)
+ | otherwise = CprSig ty
topCprSig :: CprSig
topCprSig = CprSig topCprType
-mkCprSig :: Arity -> CprResult -> CprSig
+isTopCprSig :: CprSig -> Bool
+isTopCprSig (CprSig ty) = ct_cpr ty == topCpr
+
+mkCprSig :: Arity -> Cpr -> 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'
+seqCprSig (CprSig ty) = seqCprTy ty
+
+-- | BNF:
+-- ```
+-- cpr ::= '' -- TopCpr
+-- | n -- FlatConCpr n
+-- | n '(' cpr1 ',' cpr2 ',' ... ')' -- ConCpr n [cpr1,cpr2,...]
+-- | 'b' -- BotCpr
+-- ```
+-- Examples:
+-- * `f x = f x` has denotation `b`
+-- * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`.
+instance Outputable Cpr where
+ ppr TopCpr = empty
+ ppr (FlatConCpr n) = int n
+ ppr (ConCpr n cs) = int n <> parens (pprWithCommas ppr cs)
+ ppr BotCpr = char 'b'
instance Outputable CprType where
ppr (CprType arty res) = ppr arty <> ppr res
@@ -144,20 +211,20 @@ instance Outputable CprType where
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
-
+instance Binary Cpr where
+ put_ bh TopCpr = putByte bh 0
+ put_ bh BotCpr = putByte bh 1
+ put_ bh (FlatConCpr n) = putByte bh 2 *> put_ bh n
+ put_ bh (ConCpr n cs) = putByte bh 3 *> put_ bh n *> put_ bh cs
get bh = do
- h <- getByte bh
- case h of
- 0 -> do { n <- get bh; return (ConCPR n) }
- 1 -> return NoCPR
- _ -> return BotCPR
+ h <- getByte bh
+ case h of
+ 0 -> return TopCpr
+ 1 -> return BotCpr
+ 2 -> FlatConCpr <$> get bh
+ 3 -> ConCpr <$> get bh <*> get bh
+ _ -> pprPanic "Binary Cpr: Invalid tag" (int (fromIntegral h))
instance Binary CprType where
- put_ bh (CprType arty cpr) = do
- put_ bh arty
- put_ bh cpr
- get bh = CprType <$> get bh <*> get bh
+ put_ bh (CprType arty cpr) = put_ bh arty *> put_ bh cpr
+ get bh = CprType <$> get bh <*> get bh
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 092ba1832471..36a2c9d1df8e 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -610,14 +610,14 @@ mkDataConWorkId wkr_name data_con
mkLams univ_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon res_ty_args (Var id_arg1)
-dataConCPR :: DataCon -> CprResult
+dataConCPR :: DataCon -> Cpr
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
- = conCpr (dataConTag con)
+ = flatConCpr (dataConTag con)
| otherwise
= topCpr
where
diff --git a/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
index 7f98fe0612c0..b837aeb8c57f 100644
--- a/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
+++ b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
@@ -1,7 +1,6 @@
==================== Cpr signatures ====================
-CaseBinderCPR.$trModule:
CaseBinderCPR.f_list_cmp:
-CaseBinderCPR.g: m1
+CaseBinderCPR.g: 1
diff --git a/testsuite/tests/cpranal/sigs/T19232.stderr b/testsuite/tests/cpranal/sigs/T19232.stderr
index 3aa701833b1f..59fa00d7e688 100644
--- a/testsuite/tests/cpranal/sigs/T19232.stderr
+++ b/testsuite/tests/cpranal/sigs/T19232.stderr
@@ -1,6 +1,5 @@
==================== Cpr signatures ====================
-T19232.$trModule:
T19232.f:
diff --git a/testsuite/tests/cpranal/sigs/T19398.hs b/testsuite/tests/cpranal/sigs/T19398.hs
new file mode 100644
index 000000000000..e0347fd502ab
--- /dev/null
+++ b/testsuite/tests/cpranal/sigs/T19398.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE BangPatterns #-}
+
+module T19398 where
+
+data T a = MkT !a !a
+
+f :: T a -> T a
+f (MkT a b) = MkT b a
+{-# NOINLINE f #-}
+
+-- | Should *not* have the CPR property, even though the scrutinee is a
+-- variable with the CPR property. It shows how Test (A) of
+-- Historical Note [Optimistic field binder CPR] is unsound.
+a :: Int -> Int
+a n
+ | n == 0 = n
+ | even n = case q of MkT x y -> if x == y then x else y
+ | otherwise = case q of MkT x y -> if x == y then y else x
+ where
+ q = f $ f $ f $ f $ f $ f $ f $ MkT n n
+
+-- | Should not have the CPR property, because 'x' will not be unboxed.
+-- It shows how Test (C) of Historical Note [Optimistic field binder CPR] is
+-- unsound.
+c :: (Int, Int) -> Int
+c (x,_) = x
+
+-- | An interesting artifact is that the following function has the Nested CPR
+-- property, and we could in theory exploit that:
+g :: (Int, Int) -> (Int, Int)
+g p@(!x, !y) | x == y = error "blah"
+g p = p
diff --git a/testsuite/tests/cpranal/sigs/T19398.stderr b/testsuite/tests/cpranal/sigs/T19398.stderr
new file mode 100644
index 000000000000..a293fdd08902
--- /dev/null
+++ b/testsuite/tests/cpranal/sigs/T19398.stderr
@@ -0,0 +1,8 @@
+
+==================== Cpr signatures ====================
+T19398.a:
+T19398.c:
+T19398.f: 1
+T19398.g: 1
+
+
diff --git a/testsuite/tests/cpranal/sigs/all.T b/testsuite/tests/cpranal/sigs/all.T
index f5ac233a8cd5..0647c8a6119a 100644
--- a/testsuite/tests/cpranal/sigs/all.T
+++ b/testsuite/tests/cpranal/sigs/all.T
@@ -3,7 +3,8 @@
setTestOpts(only_ways(['optasm']))
# This directory contains tests where we annotate functions with expected
# CPR signatures, and verify that these are actually those found by the compiler
-setTestOpts(extra_hc_opts('-ddump-cpr-signatures'))
+setTestOpts(extra_hc_opts('-dno-typeable-binds -ddump-cpr-signatures'))
test('CaseBinderCPR', normal, compile, [''])
test('T19232', normal, compile, [''])
+test('T19398', normal, compile, [''])
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 69f40310b473..8b3f8a53b6a5 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[final] CONLIKE] :: forall a. a :~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
- Cpr=m1,
+ Cpr=1,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 889b8f48f853..ad3878e35af0 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -44,7 +44,7 @@ dr :: Double -> Double
[GblId,
Arity=1,
Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
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)
@@ -61,7 +61,7 @@ dl :: Double -> Double
[GblId,
Arity=1,
Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
@@ -72,7 +72,7 @@ fr :: Float -> Float
[GblId,
Arity=1,
Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
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)
@@ -91,7 +91,7 @@ fl :: Float -> Float
[GblId,
Arity=1,
Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr
index ec423d7b4af1..86094fe7d9a5 100644
--- a/testsuite/tests/simplCore/should_compile/T13143.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13143.stderr
@@ -90,7 +90,7 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int
[GblId,
Arity=3,
Str=<1L><1L><1P(L)>,
- Cpr=m1,
+ Cpr=1,
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 32e34ea559d8..90bda9792fe0 100644
--- a/testsuite/tests/simplCore/should_compile/T13543.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13543.stderr
@@ -8,8 +8,8 @@ Foo.g: <1P(1P(L),1P(L))>
==================== Cpr signatures ====================
Foo.$trModule:
-Foo.f: m1
-Foo.g: m1
+Foo.f: 1
+Foo.g: 1
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index 69b1766a84f7..f33b8ec401cf 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -57,7 +57,7 @@ foo [InlPrag=[2]] :: Int -> Int
[GblId,
Arity=1,
Str=<1P(1L)>,
- Cpr=m1,
+ Cpr=1,
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/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 04e065f51cd5..66d257897e4a 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -57,7 +57,7 @@ foo [InlPrag=[2]] :: Int -> Int
[GblId,
Arity=1,
Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
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 0b45e8a3906c..fe869c7c4058 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -9,7 +9,7 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
Arity=1,
Caf=NoCafRefs,
Str=<SL>,
- Cpr=m3,
+ Cpr=3,
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)
@@ -36,7 +36,7 @@ fun2 :: forall {a}. [a] -> ((), Int)
[GblId,
Arity=1,
Str=<ML>,
- Cpr=m1,
+ Cpr=1,
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/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 683ff4d6ac74..319eba03cbe9 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -112,7 +112,7 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int
[GblId,
Arity=2,
Str=<1L><1L>,
- Cpr=m1,
+ Cpr=1,
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)
@@ -144,7 +144,7 @@ foo :: Int -> Int
[GblId,
Arity=1,
Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
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 29b6e9e8163a..481c350fc271 100644
--- a/testsuite/tests/stranal/should_compile/T10694.stderr
+++ b/testsuite/tests/stranal/should_compile/T10694.stderr
@@ -30,7 +30,7 @@ pm [InlPrag=[final]] :: Int -> Int -> (Int, Int)
[GblId,
Arity=2,
Str=<LP(L)><LP(L)>,
- Cpr=m1,
+ Cpr=1,
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 [Occ=Once1] :: Int) (w1 [Occ=Once1] :: Int) ->
diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
index 7b954564a73f..c1fa7f22e673 100644
--- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
+++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
@@ -8,7 +8,7 @@ BottomFromInnerLambda.f: <1P(SL)>
==================== Cpr signatures ====================
BottomFromInnerLambda.$trModule:
-BottomFromInnerLambda.expensive: m1
+BottomFromInnerLambda.expensive: 1
BottomFromInnerLambda.f:
diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
index 8f70d7d5e0e6..4cbc565ee2df 100644
--- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
+++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
@@ -20,10 +20,10 @@ DmdAnalGADTs.$tcD:
DmdAnalGADTs.$trModule:
DmdAnalGADTs.diverges: b
DmdAnalGADTs.f:
-DmdAnalGADTs.f': m1
+DmdAnalGADTs.f': 1
DmdAnalGADTs.g:
DmdAnalGADTs.hasCPR:
-DmdAnalGADTs.hasStrSig: m1
+DmdAnalGADTs.hasStrSig: 1
diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
index e8a806e4ad3a..09829ae4fa31 100644
--- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr
+++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
@@ -7,7 +7,7 @@ HyperStrUse.f: <1P(1P(L),A)><1L>
==================== Cpr signatures ====================
HyperStrUse.$trModule:
-HyperStrUse.f: m1
+HyperStrUse.f: 1
diff --git a/testsuite/tests/stranal/sigs/NewtypeArity.stderr b/testsuite/tests/stranal/sigs/NewtypeArity.stderr
index 5a73b535249c..66a810f5a57d 100644
--- a/testsuite/tests/stranal/sigs/NewtypeArity.stderr
+++ b/testsuite/tests/stranal/sigs/NewtypeArity.stderr
@@ -12,8 +12,8 @@ Test.t2: <1P(L)><1P(L)>
Test.$tc'MkT:
Test.$tcT:
Test.$trModule:
-Test.t: m1
-Test.t2: m1
+Test.t: 1
+Test.t2: 1
diff --git a/testsuite/tests/stranal/sigs/T12370.stderr b/testsuite/tests/stranal/sigs/T12370.stderr
index d557b437b1cc..ac5eb53888b2 100644
--- a/testsuite/tests/stranal/sigs/T12370.stderr
+++ b/testsuite/tests/stranal/sigs/T12370.stderr
@@ -8,8 +8,8 @@ T12370.foo: <1P(1P(L),1P(L))>
==================== Cpr signatures ====================
T12370.$trModule:
-T12370.bar: m1
-T12370.foo: m1
+T12370.bar: 1
+T12370.foo: 1
diff --git a/testsuite/tests/stranal/sigs/T18957.stderr b/testsuite/tests/stranal/sigs/T18957.stderr
index 2beea34dfb7e..6795bf0dab0f 100644
--- a/testsuite/tests/stranal/sigs/T18957.stderr
+++ b/testsuite/tests/stranal/sigs/T18957.stderr
@@ -14,7 +14,7 @@ T18957.$trModule:
T18957.g:
T18957.h1:
T18957.h2:
-T18957.h3: m1
+T18957.h3: 1
T18957.seq':
diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr
index 9f4953494546..db7c97f807e0 100644
--- a/testsuite/tests/stranal/sigs/T8598.stderr
+++ b/testsuite/tests/stranal/sigs/T8598.stderr
@@ -7,7 +7,7 @@ T8598.fun: <1P(L)>
==================== Cpr signatures ====================
T8598.$trModule:
-T8598.fun: m1
+T8598.fun: 1
diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr
index 691fe21c98de..b3ccac6f6e2c 100644
--- a/testsuite/tests/stranal/sigs/UnsatFun.stderr
+++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr
@@ -16,10 +16,10 @@ UnsatFun.$trModule:
UnsatFun.f: b
UnsatFun.g:
UnsatFun.g':
-UnsatFun.g3: m1
+UnsatFun.g3: 1
UnsatFun.h:
UnsatFun.h2:
-UnsatFun.h3: m1
+UnsatFun.h3: 1
--
GitLab