diff options
| author | Sebastian Graf <sgraf1337@gmail.com> | 2019-08-19 13:01:49 +0000 |
|---|---|---|
| committer | Sebastian Graf <sebastian.graf@kit.edu> | 2021-02-04 16:07:55 +0100 |
| commit | 52a045fc390f54968bfd6c17ee28fc7baef7708e (patch) | |
| tree | 9c09a7c5b69b4feb78a7c883def782e736a6c7fb | |
| parent | 89188be1ed7c1fb44e18f5ec68bf9750f425ac10 (diff) | |
| download | haskell-wip/nested-cpr-2019.tar.gz | |
Nested CPR analysis (#18174)wip/nested-cpr-2019
This commit extends CPR analysis to unbox nested constructors.
See `Note [Nested CPR]` for examples.
Unboxing a function's result beyond the first level risks making the
function more strict, rendering the transformation unsound.
See `Note [Nested CPR needs Termination information]`.
To justify unboxing anyway, Nested CPR interleaves a termination
analysis that is like a higher-order `exprOkForSpeculation`.
The termination analysis makes for the bulk of complexity in this patch.
In principle, we can use the results of that analysis in many more ways
in the future to do speculative execution.
Although there are quite a few examples in test cases that are now
properly optimised (e.g., `T1600`, `T18174`, `T18894`), the results on
NoFib are rather meager:
```
--------------------------------------------------------------------------------
Program Allocs Instrs
--------------------------------------------------------------------------------
cacheprof -0.3% -1.4%
compress2 -1.9% -0.9%
fannkuch-redux 0.0% -1.3%
gamteb -1.6% -0.3%
nucleic2 -1.2% -0.6%
sched -0.0% +0.9%
x2n1 -0.0% -5.0%
--------------------------------------------------------------------------------
Min -1.9% -5.0%
Max +0.1% +0.9%
Geometric Mean -0.1% -0.1%
```
Allocation while compiling NoFib increases by 0.5%.
Binary sizes on NoFib increase by 0.7%.
This patch manages to fix a few tickets:
Fixes #1600, #18174, #18109
`ghc/alloc` performance generally increases.
`run/alloc` metrics improve throughout.
Justifications for metric increases:
- `MultiLayerModules` increases due to #19293.
- I could reproduce the 2.5% increase on `T13701` on fedora in a `-O0`
perf-flavoured build. With `-fno-code` or `-O2` this patch is
faster. I investigated `-v2` output, nothing obvious. It's very
similar to #19293, so I'm just going to accept it.
- The +15% `ghc/alloc` increase on `T15164` in a registerised,
validate-flavoured build does not show up under `-dshow-passes` and
has no impact on runtime. #19311
- I verified that `T13253` simply does one more round of
Simplification after Nested CPR
- I looked at heap profiles for the `ghc/max_bytes_used` increases,
which didn't show any obvious offenders.
Metric Decrease:
T1969
T9203
T9233
T9872a
T9872b
T9872c
T9872d
T12425
T12545
Metric Increase ['bytes allocated']:
T13253
MultiLayerModules
Metric Increase ['bytes allocated'] (test_env='x86_64-linux-deb9-unreg-hadrian'):
T15164
Metric Increase ['bytes allocated'] (test_env='x86_64-linux-fedora27'):
T13701
Metric Increase ['max_bytes_used'] (test_env='x86_64-darwin'):
T9675
Metric Increase ['max_bytes_used'] (test_env='x86_64-linux-deb9-dwarf'):
T9675
Metric Increase ['max_bytes_used', 'peak_megabytes_allocated']:
T10370
105 files changed, 3178 insertions, 1252 deletions
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 35428156b9..7edaef1467 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -62,7 +62,6 @@ import GHC.Types.Var ( EvVar, setTyVarUnique ) import GHC.Types.TyThing import GHC.Types.Id.Info import GHC.Types.Demand -import GHC.Types.Cpr import GHC.Types.Name hiding ( varName ) import GHC.Types.Literal import GHC.Types.Unique.Supply @@ -891,9 +890,7 @@ mkExceptionId :: Name -> Id mkExceptionId name = mkVanillaGlobalWithInfo name (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a - (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv - `setCprInfo` mkCprSig 0 botCpr - `setArityInfo` 0 + (vanillaIdInfo `setDivergingInfo` [] `setCafInfo` NoCafRefs) -- #15038 mkRuntimeErrorId :: Name -> Id @@ -906,11 +903,7 @@ mkRuntimeErrorId :: Name -> Id mkRuntimeErrorId name = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info where - bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig - `setCprInfo` mkCprSig 1 botCpr - `setArityInfo` 1 - -- Make arity and strictness agree - + bottoming_info = vanillaIdInfo `setDivergingInfo` [evalDmd] -- Do *not* mark them as NoCafRefs, because they can indeed have -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, -- which has some CAFs @@ -920,8 +913,6 @@ mkRuntimeErrorId name -- any pc_bottoming_Id will itself have CafRefs, which bloats -- SRTs. - strict_sig = mkClosedStrictSig [evalDmd] botDiv - runtimeErrorTy :: Type -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a -- See Note [Error and friends have an "open-tyvar" forall] diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 99cfd1b15f..39ab7d82a4 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -12,7 +12,7 @@ -- | Arity and eta expansion module GHC.Core.Opt.Arity - ( manifestArity, joinRhsArity, exprArity, typeArity + ( manifestArity, joinRhsArity, exprArity, typeArity, splitFunNewTys , exprEtaExpandArity, findRhsArity , etaExpand, etaExpandAT , exprBotStrictness_maybe @@ -60,10 +60,11 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Builtin.Uniques import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) -import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Pair +import GHC.Data.Maybe +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Utils.Misc {- @@ -141,33 +142,37 @@ typeArity :: Type -> [OneShotInfo] -- How many value arrows are visible in the type? -- We look through foralls, and newtypes -- See Note [exprArity invariant] -typeArity ty - = go initRecTc ty +typeArity ty = mapMaybe go (fst (splitPiNewTys ty)) where - go rec_nts ty - | Just (_, ty') <- splitForAllTyCoVar_maybe ty - = go rec_nts ty' - - | Just (_,arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res + -- Important to look through non-recursive newtypes, so that, eg + -- (f x) where f has arity 2, f :: Int -> IO () + -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) + go ty_co_bndr = typeOneShot <$> binderRelevantType_maybe ty_co_bndr + +-- | Like 'splitFunTys', but this one also looks through newtypes and foralls. +splitFunNewTys :: Type -> ([Type], Type) +splitFunNewTys ty = (mapMaybe binderRelevantType_maybe arg_bndrs, res_ty) + where + (arg_bndrs, res_ty) = splitPiNewTys ty +-- | Like 'splitPiTys', but this one also looks through newtypes. +splitPiNewTys :: Type -> ([TyCoBinder], Type) +splitPiNewTys ty = go initRecTc ty [] + where + go rec_nts ty arg_tys + -- ForAllTys and FunTys + | Just (arg, res_ty) <- splitPiTy_maybe ty + = go rec_nts res_ty (arg:arg_tys) + -- See Note [Expanding newtypes] in GHC.Core.TyCon | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys - , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] - -- in GHC.Core.TyCon --- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes --- -- See Note [Newtype classes and eta expansion] --- (no longer required) - = go rec_nts' ty' - -- Important to look through non-recursive newtypes, so that, eg - -- (f x) where f has arity 2, f :: Int -> IO () - -- Here we want to get arity 1 for the result! - -- - -- AND through a layer of recursive newtypes - -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) - + , Just rec_nts' <- checkRecTc rec_nts tc + = go rec_nts' ty' arg_tys | otherwise - = [] + = (reverse arg_tys, ty) --------------- exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 177a46994a..a417504ee6 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate @@ -15,14 +18,17 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Types.Demand +import GHC.Types.Termination import GHC.Types.Cpr import GHC.Types.Unbox +import GHC.Types.Unique import GHC.Core +import GHC.Core.DataCon +import GHC.Core.Opt.Arity ( splitFunNewTys ) 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.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) @@ -35,50 +41,99 @@ import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Maybe ( isJust ) import Control.Monad ( guard ) +import Data.Coerce import Data.List ( mapAccumL ) +import GHC.Driver.Ppr +_ = pprTrace + {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that surely return heap-allocated records on every code path, so that we can -eliminate said heap allocation by performing a worker/wrapper split. - -@swap@ below is such a function: +eliminate said heap allocation by performing a worker/wrapper split +(via 'GHC.Core.Opt.WorkWrap.Utils.mkWWcpr_start'). +`swap` below is such a function: +``` swap (a, b) = (b, a) - -A @case@ on an application of @swap@, like -@case swap (10, 42) of (a, b) -> a + b@ could cancel away -(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then -say that @swap@ has the CPR property. +``` +A `case` on an application of `swap`, like +`case swap (10, 42) of (a, b) -> a + b` could cancel away +(by case-of-known-constructor) if we \"inlined\" `swap` and simplified. We then +say that `swap` has the CPR property. We can't inline recursive functions, but similar reasoning applies there: - +``` f x n = case n of 0 -> (x, 0) _ -> f (x+1) (n-1) - -Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed -product with the case. So @f@, too, has the CPR property. But we can't really -"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@ +``` +Inductively, `case f 1 2 of (a, b) -> a + b` could cancel away the constructed +product with the case. So `f`, too, has the CPR property. But we can't really +"inline" `f`, because it's recursive. Also, non-recursive functions like `swap` might be too big to inline (or even marked NOINLINE). We still want to exploit the CPR property, and that is exactly what the worker/wrapper transformation can do for us: - +``` $wf x n = case n of 0 -> case (x, 0) of -> (a, b) -> (# a, b #) _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #) f x n = case $wf x n of (# a, b #) -> (a, b) - -where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to: - +``` +where $wf readily simplifies (by case-of-known-constructor and inlining `f`) to: +``` $wf x n = case n of 0 -> (# x, 0 #) _ -> $wf (x+1) (n-1) - -Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and +``` +Now, a call site like `case f 1 2 of (a, b) -> a + b` can inline `f` and eliminate the heap-allocated pair constructor. +Note [Nested CPR] +~~~~~~~~~~~~~~~~~ +We can apply Note [Constructed Product Result] deeper than just the outer +constructor of a function, e.g., +``` + g x + | even x = (x, x+1) :: (Int, Int) + | odd x = (x+1,x+2) +``` +we certainly would want to nestedly unbox the second component of the pair! +Indeed we can give that second component the CPR property. We can even unbox +the first component, because `x` is used strictly and thus will be unboxed +(see Note [CPR for binders that will be unboxed]). We get +``` + $wg (x :: Int#) + | .. x .. = (# x, x +# 1# #) :: (# Int#, Int# #) + | .. x .. = (# x +# 1#, x +# 2# #) + g (I# x) = case $wf x of (# y, z #) -> (I# y, I# z) +``` +Nice. + +Note [Nested CPR needs Termination information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +But careful! If we follow Note [Nested CPR] blindly, we would nestedly unbox +`h1` below to get `h2`: +``` + h1 x = (x+1, x+2) + h2 x = case $wh2 x of (# y, z #) -> (I# y, I# z) + $wh2 (I# x) = (# x +# 1#, x +# 2# #) +``` +Note that `h2` is strict in `x`, whereas `h1` isn't. That is unsound, as +it changes semantics of ``h1 (error "boom") `seq` 42`` from returning 42 to +crashing. Thus, we musn't unbox and Nested CPR feeds on elaborate termination +information that says for `g` \"Both components of the pair terminate rapidly +when evaluated\". + +The termination information is computed by an analysis that shares the same +general structure as Nested CPR, hence it makes sense to interleave both. The +fact that the analysis is parameterised over instances of 'ForwardLattice', +rather than specialised to its concrete instantiations 'Term' and 'CAT' (CPR +and Term), is a testament to that structural similarity. It's well possible +to call the analysis for termination information only in the future, to serve +as a higher-order 'exprOkForSpeculation' on steroids. + Note [Phase ordering] ~~~~~~~~~~~~~~~~~~~~~ We need to perform strictness analysis before CPR analysis, because that might @@ -87,17 +142,17 @@ Ideally, we would want the following pipeline: 1. Strictness 2. worker/wrapper (for strictness) -3. CPR +3. Termination+CPR 4. worker/wrapper (for CPR) Currently, we omit 2. and anticipate the results of worker/wrapper. -See Note [CPR in a DataAlt case alternative] -and Note [CPR for binders that will be unboxed]. +See Note [CPR for binders that will be unboxed] +and Note [CPR in a DataAlt case alternative]. An additional w/w pass would simplify things, but probably add slight overhead. So currently we have 1. Strictness -2. CPR +2. Termination+CPR 3. worker/wrapper (for strictness and CPR) -} @@ -108,20 +163,23 @@ So currently we have cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram cprAnalProgram dflags fam_envs binds = do let env = emptyAnalEnv fam_envs - let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds + let binds_plus_cpr = snd $ mapAccumL (cprAnalTopBind @CAT) env binds + dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Term signatures" FormatText $ + dumpIdInfoOfProgram (ppr . termInfo) binds_plus_cpr dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_cpr `seq` return binds_plus_cpr -- Analyse a (group of) top-level binding(s) -cprAnalTopBind :: AnalEnv +cprAnalTopBind :: ForwardLattice l + => AnalEnv l -> CoreBind - -> (AnalEnv, CoreBind) + -> (AnalEnv l, CoreBind) cprAnalTopBind env (NonRec id rhs) = (env', NonRec id' rhs') where - (id', rhs', env') = cprAnalBind TopLevel env id rhs + (id', rhs', env') = cprAnalBind TopLevel env noWidening id rhs cprAnalTopBind env (Rec pairs) = (env', Rec pairs') @@ -132,201 +190,223 @@ cprAnalTopBind env (Rec pairs) -- * Analysing expressions -- --- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from --- "Constructed Product Result Analysis for Haskell" +-- | Analoguous to the abstract semantic function \(⟦_⟧ : Expr -> Env -> A\) +-- from "Constructed Product Result Analysis for Haskell" cprAnal, cprAnal' - :: AnalEnv + :: ForwardLattice l + => AnalEnv l + -> [l] -- ^ info about incoming arguments -> CoreExpr -- ^ expression to be denoted by a 'CprType' - -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' + -> (l, CoreExpr) -- ^ the updated expression and its 'CprType' -cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ - cprAnal' env e +cprAnal env args e = -- pprTrace "cprAnal" (ppr (fst (res)) $$ ppr e) $ + res where res = cprAnal' env args e -cprAnal' _ (Lit lit) = (topCprType, Lit lit) -cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact -cprAnal' _ (Coercion co) = (topCprType, Coercion co) +cprAnal' _ _ (Lit lit) = (whnfOk, Lit lit) +cprAnal' _ _ (Type ty) = (whnfOk, Type ty) -- Doesn't happen, in fact +cprAnal' _ _ (Coercion co) = (whnfOk, Coercion co) -cprAnal' env (Var var) = (cprTransform env var, Var var) +cprAnal' env args (Var var) = (cprTransform env args var, Var var) -cprAnal' env (Cast e co) +cprAnal' env args (Cast e co) = (cpr_ty, Cast e' co) where - (cpr_ty, e') = cprAnal env e + (cpr_ty, e') = cprAnal env args e -cprAnal' env (Tick t e) +cprAnal' env args (Tick t e) = (cpr_ty, Tick t e') where - (cpr_ty, e') = cprAnal env e + (cpr_ty, e') = cprAnal env args e -cprAnal' env (App fun (Type ty)) +cprAnal' env args (App fun (Type ty)) = (fun_ty, App fun' (Type ty)) where - (fun_ty, fun') = cprAnal env fun + (fun_ty, fun') = cprAnal env args fun -cprAnal' env (App fun arg) - = (res_ty, App fun' arg') +cprAnal' env args (App fun arg) + = (app_ty, App fun' arg') where - (fun_ty, fun') = cprAnal env fun - -- In contrast to DmdAnal, there is no useful (non-nested) CPR info to be - -- had by looking into the CprType of arg. - (_, arg') = cprAnal env arg - res_ty = applyCprTy fun_ty - -cprAnal' env (Lam var body) + (arg_ty, arg') = cprAnal env [] arg + -- NB: arg_ty may have the CPR property. That is indeed important for data + -- constructors. + (fun_ty, fun') = cprAnal env (arg_ty:args) fun + app_ty = app fun_ty +cprAnal' env args (Lam var body) | isTyVar var - , (body_ty, body') <- cprAnal env body + , (body_ty, body') <- cprAnal env args body = (body_ty, Lam var body') | otherwise = (lam_ty, Lam var body') where - env' = extendSigEnvForDemand env var (idDemandInfo var) - (body_ty, body') = cprAnal env' body - lam_ty = abstractCprTy body_ty - -cprAnal' env (Case scrut case_bndr ty alts) - = (res_ty, Case scrut' case_bndr ty alts') + (arg_ty, body_args) + | ty:args' <- args = (ty, args') -- Info from e.g. a StrictSig or DataCon wrapper args + | otherwise = (top, []) -- An anonymous lambda + arg_sig = mkPlainSig (idArity var) arg_ty + env' = extendSigEnv env var arg_sig + (body_ty, body') = cprAnal env' body_args body + lam_ty = lam body_ty + +cprAnal' env args (Case scrut case_bndr ty alts) + = -- pprTrace "cprAnal:Case" (ppr scrut $$ text "ty:" <+> ppr ty $$ ppr scrut_ty $$ ppr alt_tys $$ ppr res_ty) $ + (res_ty, Case scrut' case_bndr ty alts') where - (_, scrut') = cprAnal env scrut - -- Regardless whether scrut had the CPR property or not, the case binder - -- certainly has it. See 'extendEnvForDataAlt'. - (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts - res_ty = foldl' lubCprType botCprType alt_tys - -cprAnal' env (Let (NonRec id rhs) body) + -- Analyse the scrutinee and additionally force the resulting CPR type with + -- head strictness. + (scrut_ty, scrut') = cprAnal env [] scrut + (whnf_flag, case_bndr_ty) = forceWhnf scrut_ty + case_bndr_sig = mkPlainSig (idArity case_bndr) case_bndr_ty + env_alts = extendSigEnv env case_bndr case_bndr_sig + (alt_tys, alts') = mapAndUnzip (cprAnalAlt env_alts args case_bndr_ty) alts + res_ty = lubs alt_tys `both` whnf_flag + +cprAnal' env args (Let (NonRec id rhs) body) = (body_ty, Let (NonRec id' rhs') body') where - (id', rhs', env') = cprAnalBind NotTopLevel env id rhs - (body_ty, body') = cprAnal env' body + (id', rhs', env') = cprAnalBind NotTopLevel env noWidening id rhs + (body_ty, body') = cprAnal env' args body -cprAnal' env (Let (Rec pairs) body) +cprAnal' env args (Let (Rec pairs) body) = body_ty `seq` (body_ty, Let (Rec pairs') body') where (env', pairs') = cprFix NotTopLevel env pairs - (body_ty, body') = cprAnal env' body + (body_ty, body') = cprAnal env' args body cprAnalAlt - :: AnalEnv - -> CoreExpr -- ^ scrutinee - -> Id -- ^ case binder - -> Alt Var -- ^ current alternative - -> (CprType, Alt Var) -cprAnalAlt env scrut case_bndr (Alt con@(DataAlt dc) bndrs rhs) - -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] - = (rhs_ty, Alt con bndrs rhs') - where - env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs - (rhs_ty, rhs') = cprAnal env_alt rhs -cprAnalAlt env _ _ (Alt con bndrs rhs) + :: ForwardLattice l + => AnalEnv l + -> [l] -- ^ info about incoming arguments + -> l -- ^ info about the case binder + -> Alt Var -- ^ current alternative + -> (l, Alt Var) +cprAnalAlt env args case_bndr_ty (Alt con bndrs rhs) = (rhs_ty, Alt con bndrs rhs') where - (rhs_ty, rhs') = cprAnal env rhs + env_alt + -- See Note [CPR in a DataAlt case alternative] + | DataAlt dc <- con + , let ids = filter isId bndrs + , let field_tys = expandConFields dc case_bndr_ty + , let sigs = zipWith (mkPlainSig . idArity) ids field_tys + = extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs) + | otherwise + = env + (rhs_ty, rhs') = cprAnal env_alt args rhs -- -- * CPR transformer -- -cprTransform :: AnalEnv -- ^ The analysis environment - -> Id -- ^ The function - -> CprType -- ^ The demand type of the function -cprTransform env id - = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig]) +cprTransform + :: ForwardLattice l + => AnalEnv l -- ^ The analysis environment + -> [l] -- ^ info about incoming arguments + -> Id -- ^ The function + -> l -- ^ The demand type of the function +cprTransform env args id + = -- pprTrace "cprTransform" (vcat [ppr id, ppr sig, ppr args]) sig where sig - -- Top-level binding, local let-binding or case binder - | Just sig <- lookupSigEnv env id - = getCprSig sig + -- Top-level binding, local let-binding, lambda arg or case binder + | Just (str_sig, sig) <- lookupSigEnv env id + = transformSig uniq arity str_sig sig args -- See Note [CPR for data structures] | Just rhs <- cprDataStructureUnfolding_maybe id - = fst $ cprAnal env rhs + = fst $ cprAnal env args rhs + -- See Note [CPR for DataCon wrappers] + | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id) + = fst $ cprAnal env args rhs + -- Data constructor + | Just con <- isDataConWorkId_maybe id + = transformDataConWork con args -- Imported function or data con worker | isGlobalId id - = getCprSig (idCprInfo id) + = transformSig uniq arity id_str_sig id_ann args | otherwise - = topCprType + = top + uniq = idUnique id + arity = idArity id + id_str_sig = idStrictness id + id_ann = getAnalAnnotation id -- --- * Bindings +-- * Analysing Bindings -- --- Recursive bindings -cprFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding - -> [(Id,CoreExpr)] - -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info -cprFix top_lvl orig_env orig_pairs - = loop 1 init_env init_pairs - where - init_sig id rhs - -- See Note [CPR for data structures] - | isDataStructure id rhs = topCprSig - | otherwise = mkCprSig 0 botCpr - -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal - 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) +-- +-- ** Widening +-- - -- 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 - -- any more. - loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) - loop n env pairs - | found_fixpoint = (reset_env', pairs') - | otherwise = loop (n+1) env' pairs' - where - -- In all but the first iteration, delete the virgin flag - -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal - (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs - -- Make sure we reset the virgin flag to what it was when we are stable - reset_env' = env'{ ae_virgin = orig_virgin } - found_fixpoint = map (idCprInfo . fst) pairs' == map (idCprInfo . fst) pairs +type Widening l = Sig l -> Sig l - step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)]) - step env pairs = mapAccumL go env pairs - where - go env (id, rhs) = (env', (id', rhs')) - where - (id', rhs', env') = cprAnalBind top_lvl env id rhs +noWidening :: Widening l +noWidening = id + +-- | A widening operator on 'Sig' to ensure termination of fixed-point +-- iteration. See Note [Ensuring termination of fixed-point iteration] +depthWidening :: ForwardLattice l => Widening l +depthWidening = pruneDepth mAX_DEPTH . markDiverging + +-- This constant is quite arbitrary. We might well make it a CLI flag if needed +mAX_DEPTH :: Int +mAX_DEPTH = 4 + +-- +-- ** Analysing a binding (one-round, the non-recursive case) +-- -- | Process the RHS of the binding for a sensible arity, add the CPR signature -- to the Id, and augment the environment with the signature as well. cprAnalBind - :: TopLevelFlag - -> AnalEnv + :: forall l. ForwardLattice l + => TopLevelFlag + -> AnalEnv l + -> Widening l -- ^ We want to specify 'depthWidening' in fixed-point iteration -> Id -> CoreExpr - -> (Id, CoreExpr, AnalEnv) -cprAnalBind top_lvl env id rhs + -> (Id, CoreExpr, AnalEnv l) +cprAnalBind top_lvl env widening id rhs -- See Note [CPR for data structures] | isDataStructure id rhs - = (id, rhs, env) -- Data structure => no code => need to analyse rhs + = (id, rhs, env) -- Data structure => no code => no need to analyse rhs | otherwise = (id', rhs', env') where - (rhs_ty, rhs') = cprAnal env rhs + arg_tys = fst (splitFunNewTys (idType id)) + -- See Note [CPR for binders that will be unboxed] + -- See Note [Rapid termination for strict binders] + assumed_arg_cpr_tys = argsFromStrictSig (unboxingStrategy env) + arg_tys + (idStrictness id) + + (rhs_ty, rhs') = cprAnal env assumed_arg_cpr_tys rhs + -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty + | stays_thunk = forgetCpr rhs_ty -- See Note [CPR for sum types] - | returns_sum = trimCprTy rhs_ty + | returns_sum = forgetCpr rhs_ty | otherwise = rhs_ty + -- See Note [Arity trimming for CPR signatures] - sig = mkCprSigForArity (idArity id) rhs_ty' - id' = setIdCprInfo id sig - env' = extendSigEnv env id sig + -- See Note [Trimming CPR signatures according to Term] + -- See Note [Ensuring termination of fixed-point iteration] + dmd = idDemandInfo id + sig = widening $ mkFunSig (idArity id) dmd rhs_ty' + id' = -- pprTrace "cprAnalBind" (ppr id $$ ppr rhs_ty' $$ ppr (idArity id) $$ ppr dmd $$ ppr sig) $ + setAnalAnnotation @l id sig + env' = extendSigEnv env id sig -- See Note [CPR for thunks] - stays_thunk = is_thunk && not_strict is_thunk = not (exprIsHNF rhs) && not (isJoinId id) - not_strict = not (isStrUsedDmd (idDemandInfo id)) + strict = isStrUsedDmd dmd + stays_thunk = is_thunk && not strict -- See Note [CPR for sum types] (_, ret_ty) = splitPiTys (idType id) returns_prod | Just (tc, _, _) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty - , Just _prod_dc <- tyConSingleAlgDataCon_maybe tc - = True + = isJust (tyConSingleAlgDataCon_maybe tc) | otherwise = False returns_sum = not (isTopLevel top_lvl) && not returns_prod @@ -334,7 +414,7 @@ cprAnalBind top_lvl env id rhs isDataStructure :: Id -> CoreExpr -> Bool -- See Note [CPR for data structures] isDataStructure id rhs = - idArity id == 0 && exprIsHNF rhs + idArity id == 0 && not (isJoinId id) && exprIsHNF rhs -- | Returns an expandable unfolding -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has @@ -347,6 +427,64 @@ cprDataStructureUnfolding_maybe id = do guard (isDataStructure id unf) return unf +unboxingStrategy :: AnalEnv l -> UnboxingStrategy Demand +unboxingStrategy env = wantToUnboxArg (ae_fam_envs env) has_inlineable_prag + where + -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE + -- function, we just assume that we are. 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 = True + +-- +-- ** Analysing recursive bindings +-- + +-- | Fixed-point iteration +cprFix + :: forall l. ForwardLattice l + => TopLevelFlag + -> AnalEnv l -- Does not include bindings for this binding + -> [(Id,CoreExpr)] + -> (AnalEnv l, [(Id,CoreExpr)]) -- Binders annotated with CPR info +cprFix top_lvl orig_env orig_pairs + = loop 1 init_env init_pairs + where + init_sig id rhs + -- See Note [CPR for data structures] + | isDataStructure id rhs = Sig $ top + | otherwise = Sig $ bot + -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal + orig_virgin = ae_virgin orig_env + init_pairs | orig_virgin = [(setAnalAnnotation @l id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_pairs + init_env = extendSigEnvFromIds orig_env (map fst init_pairs) + + -- The fixed-point varies the idCprInfo/idTermInfo field of the binders and + -- their entries in the AnalEnv, and terminates if that annotation does not + -- change any more. + loop :: Int -> AnalEnv l -> [(Id,CoreExpr)] -> (AnalEnv l, [(Id,CoreExpr)]) + loop n env pairs + | found_fixpoint = (reset_env', pairs') + | otherwise = -- pprTrace "cprFix:loop" (ppr n <+> ppr (map _prj pairs) <+> ppr (map _prj pairs')) $ + loop (n+1) env' pairs' + where + -- In all but the first iteration, delete the virgin flag + -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal + (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs + -- Make sure we reset the virgin flag to what it was when we are stable + reset_env' = env'{ ae_virgin = orig_virgin } + get_anns = map (getAnalAnnotation @l . fst) + found_fixpoint = get_anns pairs' == get_anns pairs + _prj (id,_) = (id, getAnalAnnotation @l id) -- a helper fun for the trace call + + step :: AnalEnv l -> [(Id, CoreExpr)] -> (AnalEnv l, [(Id, CoreExpr)]) + step env pairs = mapAccumL go env pairs + where + go env (id, rhs) = (env', (id', rhs')) + where + (id', rhs', env') = cprAnalBind top_lvl env depthWidening id rhs + {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Although it doesn't affect correctness of the analysis per se, we have to trim @@ -377,12 +515,62 @@ from @f@'s, so it *will* be WW'd: And the case in @g@ can never cancel away, thus we introduced extra reboxing. Hence we always trim the CPR signature of a binding to idArity. + +Note [Trimming CPR signatures according to Term] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f :: Int -> Maybe Int + f n = Just (sum [0..n]) -- assume that `sum` has the CPR property + g :: Int -> Int + g n | n < 0 = n + | otherwise = case f n of Just blah -> blah + +For the RHS of 'f', we infer the CPR type `1->#c2(*c1(#))`. That is enough to +unbox the 'Just' constructor, but not the nested 'I#' constructor, which would +evaluate the expensive `sum` expression. So we give 'f' the CPR signature +`1->#c2(*)`, which inhibits WW from unboxing the 'I#'. + +Why not do the trimming in WW? Because then we might get CPR where we wouldn't +expect it, like 'g' above. If we gave 'f' the CPR sig `1->#c2(*c1(#))`, then +'blah' would have the CPR type `*c1(#)`. In total, 'g' would have the CPR sig +`1->*c1(*)` and WW would unbox it, but the `case` on `f` would never cancel +away and we'd rebox the `Int` returned from 'f'. + +Note [Improving CPR by considering strictness demand from call sites] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider `T18894`: + + module T18894 (h) where + g :: Int -> Int -> (Int,Int) + g !m 1 = (2 + m, 0) + g m n = (2 * m, 2 `div` n) + h :: Int -> Int + h 1 = 0 + h m | odd m = snd (g m 2) + | otherwise = uncurry (+) (g 2 m) + +We infer CPR type `2->#c1(#c1(*), *c1(*))` for 'g's RHS and by +Note [Trimming CPR signatures according to Term] we *should* trim that to +`2->c1(c1(*), *))` for the CPR signature, because unboxing the division might in +fact diverge and throw a div-by-zero exception. + +But if you look at how 'g' is called, you'll see that all call sites evaluate +the second component of the returned pair anyway! So acutally it would have been +OK to unbox the division, because all call sites force it anyway. + +Demand analysis infers a demand of `UCU(CS(P(1P(U),SP(U))))` on 'g'. Note how +it says that all call sites evaluate the second component of the pair! We use +that to improve the termination information with which we trim CPR, as if we +had inferred `2->#c1(#c1(*), #c1(*))` instead, to get CPR `2->c1(c1(*),c1(*))` +and unbox both components of the pair. -} -data AnalEnv +data AnalEnv l = AE - { ae_sigs :: SigEnv - -- ^ Current approximation of signatures for local ids + { ae_sigs :: IdEnv (StrictSig, Sig l) + -- ^ The 'StrictSig' from the binding site and the current approximation of + -- the signature for local ids. See Note [Why must AnalEnv carry StrictSigs?]. , ae_virgin :: Bool -- ^ True only on every first iteration in a fixed-point -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal" @@ -390,15 +578,13 @@ data AnalEnv -- ^ Needed when expanding type families and synonyms of product types. } -type SigEnv = VarEnv CprSig - -instance Outputable AnalEnv where +instance Outputable l => Outputable (AnalEnv l) where ppr (AE { ae_sigs = env, ae_virgin = virgin }) = text "AE" <+> braces (vcat [ text "ae_virgin =" <+> ppr virgin , text "ae_sigs =" <+> ppr env ]) -emptyAnalEnv :: FamInstEnvs -> AnalEnv +emptyAnalEnv :: FamInstEnvs -> AnalEnv l emptyAnalEnv fam_envs = AE { ae_sigs = emptyVarEnv @@ -406,141 +592,153 @@ emptyAnalEnv fam_envs , 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 ] - -extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv -extendSigEnv env id sig - = env { ae_sigs = extendVarEnv (ae_sigs env) id sig } - -lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig +lookupSigEnv :: AnalEnv l -> Id -> Maybe (StrictSig, Sig l) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - --- | A version of 'extendSigEnv' for a binder of which we don't see the RHS --- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders). --- 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 - , Unbox (DataConPatContext { dcpc_dc = dc }) _ - <- wantToUnboxArg (ae_fam_envs env) has_inlineable_prag (idType id) dmd - = extendSigEnv env id (CprSig (conCprType (dataConTag dc))) - | otherwise - = env - where - -- 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 +extendSigEnv :: AnalEnv l -> Id -> (Sig l) -> AnalEnv l +-- See Note [Why must AnalEnv carry StrictSigs?] +extendSigEnv env id !sig + = env { ae_sigs = extendVarEnv (ae_sigs env) id (idStrictness id, sig) } -extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv --- See Note [CPR in a DataAlt case alternative] -extendEnvForDataAlt env scrut case_bndr dc bndrs - = foldl' do_con_arg env' ids_w_strs +extendSigEnvList :: AnalEnv l -> [(Id, Sig l)] -> AnalEnv l +-- See Note [Why must AnalEnv carry StrictSigs?] +extendSigEnvList env ids_cprs + = env { ae_sigs = extendVarEnvList (ae_sigs env) ids_strs_cprs } where - env' = extendSigEnv env case_bndr (CprSig case_bndr_ty) - - ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc - - is_algebraic = isJust (tyConAlgDataCons_maybe (dataConTyCon dc)) - no_exs = null (dataConExTyCoVars dc) - case_bndr_ty - | is_algebraic, no_exs = conCprType (dataConTag dc) - -- The tycon wasn't algebraic or the datacon had existentials. - -- See Note [Which types are unboxed?] for why no existentials. - | otherwise = topCprType - - -- We could have much deeper CPR info here with Nested CPR, which could - -- propagate available unboxed things from the scrutinee, getting rid of - -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative]. - -- Giving strict binders the CPR property only makes sense for products, as - -- the arguments in Note [CPR for binders that will be unboxed] don't apply - -- to sums (yet); we lack WW for strict binders of sum type. - do_con_arg env (id, str) - | is_var scrut - -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils - , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id) - = extendSigEnvForDemand env id dmd - | otherwise - = env - - is_var (Cast e _) = is_var e - is_var (Var v) = isLocalId v - is_var _ = False - -{- Note [Safe abortion in the fixed-point iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Fixed-point iteration may fail to terminate. But we cannot simply give up and -return the environment and code unchanged! We still need to do one additional -round, to ensure that all expressions have been traversed at least once, and any -unsound CPR annotations have been updated. + ids_strs_cprs = [ (id, (str_sig, cpr)) | (id, !cpr) <- ids_cprs + , let str_sig = idStrictness id ] -Note [CPR in a DataAlt case alternative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case alternative, we want to give some of the binders the CPR property. -Specifically +-- | Extend an environment with the CPR sigs attached to the ids +extendSigEnvFromIds :: ForwardLattice l => AnalEnv l -> [Id] -> AnalEnv l +extendSigEnvFromIds env ids + = extendSigEnvList env [ (id, getAnalAnnotation id) | id <- ids ] - * The case binder; inside the alternative, the case binder always has - the CPR property, meaning that a case on it will successfully cancel. - Example: - f True x = case x of y { I# x' -> if x' ==# 3 - then y - else I# 8 } - f False x = I# 3 +nonVirgin :: AnalEnv l -> AnalEnv l +nonVirgin env = env { ae_virgin = False } - By giving 'y' the CPR property, we ensure that 'f' does too, so we get - f b x = case fw b x of { r -> I# r } - fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } - fw False x = 3 - - Of course there is the usual risk of re-boxing: we have 'x' available - boxed and unboxed, but we return the unboxed version for the wrapper to - box. If the wrapper doesn't cancel with its caller, we'll end up - re-boxing something that we did have available in boxed form. - - * Any strict binders with product type, can use - Note [CPR for binders that will be unboxed] - to anticipate worker/wrappering for strictness info. - But we can go a little further. Consider - - data T = MkT !Int Int - - f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) - | otherwise = x - - For $wf2 we are going to unbox the MkT *and*, since it is strict, the - first argument of the MkT; see Note [Add demands for strict constructors]. - But then we don't want box it up again when returning it! We want - 'f2' to have the CPR property, so we give 'x' the CPR property. - - * It's a bit delicate because we're brittly anticipating worker/wrapper here. - If the case above is scrutinising something other than an argument the - original function, we really don't have the unboxed version available. E.g - g v = case foo v of - MkT x y | y>0 -> ... - | otherwise -> x - Here we don't have the unboxed 'x' available. Hence the - is_var_scrut test when making use of the strictness annotation. - Slightly ad-hoc, because even if the scrutinee *is* a variable it - might not be a onre of the arguments to the original function, or a - sub-component thereof. But it's simple, and nothing terrible - happens if we get it wrong. e.g. Trac #10694. +class (Eq l, Outputable l) => ForwardLattice l where + bot :: l + top :: l + lub :: l -> l -> l + whnfOk :: l + app :: l -> l + lam :: l -> l + markDiverging :: Sig l -> Sig l + pruneDepth :: Int -> Sig l -> Sig l + forceWhnf :: l -> (TermFlag, l) + both :: l -> TermFlag -> l + expandConFields :: DataCon -> l -> [l] + argsFromStrictSig :: UnboxingStrategy Demand -> [Type] -> StrictSig -> [l] + forgetCpr :: l -> l + mkFunSig :: Arity -> Demand -> l -> Sig l -- for lets/top-level funs + mkPlainSig :: Arity -> l -> Sig l -- for any other binding + transformSig :: Unique -> Arity -> StrictSig -> Sig l -> [l] -> l + transformDataConWork :: DataCon -> [l] -> l + getAnalAnnotation :: Id -> Sig l + setAnalAnnotation :: Id -> Sig l -> Id + +lubs :: ForwardLattice l => [l] -> l +lubs = foldl' lub bot + +instance ForwardLattice Term where + bot = botTerm + top = topTerm + lub = lubTerm + whnfOk = whnfTerm + app = appTerm + lam = lamTerm + markDiverging = coerce (lub divergeTerm) + pruneDepth = coerce pruneDeepTerm + forceWhnf = forceTerm topSubDmd + both = bothTerm + expandConFields = expandConFieldsTerm + argsFromStrictSig _want_to_unbox _arg_tys = argTermsFromStrictSig + forgetCpr = id + mkFunSig arity _dmd term = mkTermSig arity term -- NB: Term doesn't care, + mkPlainSig arity term = mkTermSig arity term -- only CPR does + transformSig _uniq = termTransformSig + transformDataConWork = termTransformDataConWork + getAnalAnnotation = idTermInfo + setAnalAnnotation = setIdTermInfo + +-- | Joint lattice of 'Term' and 'Cpr'. +-- (C)pr (A)nd (T)ermination, hence \"CAT\". +data CAT = CAT !Term !Cpr + deriving Eq + +instance Outputable CAT where + ppr (CAT t c) = parens (ppr t <> comma <+> ppr c) + +unzipCAT :: [CAT] -> ([Term], [Cpr]) +unzipCAT = unzip . map (\(CAT t c) -> (t, c)) + +-- | Like 'Control.Arrow.(***)' for 'CAT'. +liftCAT :: (Term -> Term) -> (Cpr -> Cpr) -> CAT -> CAT +liftCAT ft fc (CAT t c) = CAT (ft t) (fc c) + +instance ForwardLattice CAT where + bot = CAT bot botCpr + top = CAT top topCpr + lub (CAT t1 c1) (CAT t2 c2) = CAT (lub t1 t2) (lubCpr c1 c2) + whnfOk = CAT whnfOk topCpr + app = liftCAT app appCpr + lam = liftCAT lam lamCpr + markDiverging (Sig (CAT t c)) = Sig (CAT (coerce (markDiverging @Term) t) c) + pruneDepth d = coerce (liftCAT (coerce (pruneDepth @Term d)) (pruneDeepCpr d)) + forceWhnf (CAT t c) = (tf, CAT t' c) + where + (!tf, !t') = forceWhnf t + both (CAT t c) tf = CAT (t `both` tf) c + expandConFields dc (CAT t c) = + zipWith CAT (expandConFields dc t) (expandConFieldsCpr dc c) + argsFromStrictSig want_to_unbox arg_tys str_sig = + zipWith CAT (argsFromStrictSig want_to_unbox arg_tys str_sig) + (argCprsFromStrictSig want_to_unbox arg_tys str_sig) + forgetCpr (CAT t c) = CAT t (dropNonBotCpr c) + mkFunSig arity demand (CAT t c) = + -- NB: This is the dependency from Term to Cpr analysis! + Sig $ CAT (getSig $ mkFunSig arity demand t) + (getSig $ mkFunCprSig arity demand t c) + mkPlainSig arity (CAT t c) = + -- NB: No dependency here. + Sig $ CAT (getSig $ mkPlainSig arity t) + (getSig $ mkPlainCprSig arity c) + transformSig uniq arty str_sig (Sig (CAT sig_t sig_c)) args = + CAT (transformSig uniq arty str_sig (Sig sig_t) arg_terms) + (cprTransformSig uniq arty (Sig sig_c) arg_cprs) + where + (arg_terms, arg_cprs) = unzipCAT args + transformDataConWork dc args = + CAT (transformDataConWork dc arg_terms) + (cprTransformDataConWork dc arg_cprs) + where + (arg_terms, arg_cprs) = unzipCAT args + getAnalAnnotation id = + Sig $ CAT (getSig $ getAnalAnnotation id) (getSig $ idCprInfo id) + setAnalAnnotation id (Sig (CAT t c)) = + id `setAnalAnnotation` Sig t `setIdCprInfo` Sig c + +{- Note [Ensuring termination of fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Fixed-point iteration may fail to terminate for a function like repeat: + + repeat x = x : repeat x + +In the first round, we will infer the Cpr 2(-, -). +In the second round, we will infer the Cpr 2(-, 2(-, -)). +And so on. + +Hence it is important to apply a /widening/ operator between iterations to +ensure termination. In the case of DmdAnal, that is simply a check on the +number of iterations, defaulting to Top after a certain limit +(See Note [Safe abortion in the fixed-point iteration] in DmdAnal). +In case of CprAnal, we simply prune Cpr and Term info after each +iteration to a constant depth of mAX_DEPTH. Note [CPR for binders that will be unboxed] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a lambda-bound variable will be unboxed by worker/wrapper (so it must be -demanded strictly), then give it a CPR signature. Here's a concrete example +demanded strictly), then give it the CPR property. Here's a concrete example ('f1' in test T10482a), assuming h is strict: f1 :: Int -> Int @@ -557,21 +755,109 @@ of 'h' in the example). Moreover, if f itself is strict in x, then we'll pass x unboxed to f1, and so the boxed version *won't* be available; in that case it's -very helpful to give 'x' the CPR property. +very helpful to give 'x' the CPR property. Otherwise, the worker would +*rebox* 'x' before returning it. -Note that +Note that we only want to do this for something that we want to unbox +('wantToUnboxArg'), else we may get over-optimistic CPR results +(e.g. from \x -> x!). - * We only want to do this for something that definitely - has product type, else we may get over-optimistic CPR results - (e.g. from \x -> x!). +In practice, we derive CPR information directly from the strictness signature +and the argument type in 'cprAnalBind' via 'argCATsFromStrictSig'. - * This also (approximately) applies to DataAlt field binders; - See Note [CPR in a DataAlt case alternative]. +Note [Rapid termination for strict binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Evaluation of any strict binder will rapidly terminate once strictness +worker/wrapper has happened. Here's an example: + + g :: Int -> Int -> (Int, Int) + g x | x > 0 = (x, x) + | otherwise = (0, 0) + +We want to nestedly unbox the components of the constructed pair, but we +may only do so if we can prove that 'x' terminates rapidly. And indeed it +does! As strictness analysis will tell, 'g' would eval 'x' anyway, so it +is OK to regard 'x' as if it terminates rapidly, because any additional +evaluation beyond the first one will. We get + + g (I# x) = case $wg x of (# a, b #) -> (I# a, I# b) + $wg x | x ># 0# = (# x, x #) + | otherwise = (# 0#, 0# #) + +Like for Note [CPR for binders that will be unboxed], we derive +termination information directly from the strictness signature +in 'cprAnalBind' via 'argCATsFromStrictSig'. + +But in contrast to CPR information, we also have to account for termination of +strict arguments at *call sites* of 'g'! For example + + h :: Int -> ((Int, Int), (Int, Int)) + h z = (g z, g 42) + +We saw that 'g' can be unboxed nestedly. And we'd even say that calls to 'g' +itself terminate rapidly, provided its argument 'x' terminates. +Now, can we unbox the pair returned by 'h' nestedly? No! Evaluating +`h (error "boom")` will terminate just fine, but not if we decide to +unbox the first component of 'h'. The key is that we have to uphold +the "provided its argument terminates" precondition at call sites of 'g'. +That clearly is not the case for 'z', which is a lazy binder. + +The solution is to "force" 'z' according to the strictness +signature of 'g', which is what 'cprTransformSig' does. It +accounts the TermFlag resulting from the forcing to +the termination recorded in the signature, as if there was +a case expression forcing the argument before the call. In +case of 'g', we get that it MightDiverge because forcing of +the argument 'z' MightDiverge. + +Why not simply say that 'g' MightDiverge, so that we don't have to be smart at +call sites? Because then we don't get to see that *any* function that uses its +arguments terminates rapidly! In particular, we'd miss to unbox `g 42` above, +which is perfectly within limits; evaluation of `42` terminates rapidly and then +so does the call `g 42`, which allows to unbox the second component of 'h', thus + + h z = case $wh z of + (# p, a, b #) -> (p, (I# a, I# b)) + $wh z = case $wg 42 of + (# a, b #) -> (# g z, a, b #) - * See Note [CPR examples] +Note [CPR in a DataAlt case alternative] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case alternative, we want to give some of the binders the CPR property. +Specifically + + * The case binder. Inside the alternative, the case binder always has + the CPR property if the scrutinee has it, meaning that a case on it will + successfully cancel. Example: + f x = case x of y { I# x' -> if x' ==# 3 + then y + else I# 8 } + + Since 'x' is used strictly, it will be unboxed and given the CPR property + (See Note [CPR for binders that will be unboxed]). + By giving 'y' the CPR property, we ensure that 'f' does too, so we get + f (I# x) = I# (fw x) + fw x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + + If the scrutinee has the CPR property, giving it to the case binder will + never introduce reboxing. We used to be more optimistic before Nested CPR; + see #19232. + + * The field binders. If the scrutinee had nested CPR information, the field + binders inherit that information. + Example (adapted from T10482a): + f2 t = case t of (x, y) + | x<0 -> f2 (MkT2 x (y-1)) + | y>1 -> 1 + | otherwise -> x + Since 'f2' is strict in 't' and even 'x', they will be available unboxed-only. + Note [CPR for binders that will be unboxed] gives 't' an appropriately nested + CPR property from which the field binder 'x' inherits its CPR property in turn, + so that we give 'f2' the CPR property. Implementation in 'extendEnvForDataAlt'. Note [CPR for sum types] ~~~~~~~~~~~~~~~~~~~~~~~~ +This is out of date since we have join points. See #16570 At the moment we do not do CPR for let-bindings that * non-top level * bind a sum type @@ -678,8 +964,9 @@ should not get CPR signatures (#18154), because they Hence we don't analyse or annotate data structures in 'cprAnalBind'. To implement this, the isDataStructure guard is triggered for bindings that satisfy - (1) idArity id == 0 (otherwise it's a function) - (2) exprIsHNF rhs (otherwise it's a thunk, Note [CPR for thunks] applies) + (1a) idArity id == 0 (otherwise it's a function) + (1b) not (isJoinId id) (otherwise it counts as a function) + (2) exprIsHNF rhs (otherwise it's a thunk, Note [CPR for thunks] applies) But we can't just stop giving DataCon application bindings the CPR *property*, for example @@ -722,28 +1009,24 @@ uncommon to find code like this, whereas the long static data structures from the beginning of this Note are very common because of GHC's strategy of ANF'ing data structure RHSs. -Note [CPR examples] -~~~~~~~~~~~~~~~~~~~~ -Here are some examples (stranal/should_compile/T10482a) of the -usefulness of Note [CPR in a DataAlt case alternative]. The main -point: all of these functions can have the CPR property. - - ------- f1 ----------- - -- x is used strictly by h, so it'll be available - -- unboxed before it is returned in the True branch - - f1 :: Int -> Int - f1 x = case h x x of - True -> x - False -> f1 (x-1) - - ------- f3 ----------- - -- h is strict in x, so x will be unboxed before it - -- is rerturned in the otherwise case. - - data T3 = MkT3 Int Int - - f1 :: T3 -> Int - f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) - | otherwise = x +Note [CPR for DataCon wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat DataCon wrappers simply by analysing their unfolding. Why not analyse +the unfolding once, upfront? Two reasons: + + 1. It's simpler to analyse the unfolding anew at every call site, and the + unfolding will be pretty cheap to analyse. + 2. The CPR sig we would give the wrapper in 'GHC.Types.Id.Make.mkDataConRep' + would not take into account whether the arguments to the wrapper had the + CPR property itself! That would make the CPR transformers derived from + CPR sigs for DataCon wrappers much less precise than the transformer for + DataCon workers ('cprTransformDataConWork'). + +Note [Why must AnalEnv carry StrictSigs?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Termination analysis depends on accurate strictness signatures at *call sites*. +But termination analysis directly follows demand analysis! That means, the +'idStrictness' of 'Var' uses won't have been updated yet, because there was no +intermittent run of occurrence analysis. +Solution: Track 'idStrictness' from the binding site in 'ae_sigs'. -} diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 6a21063f22..2b5d04d5ba 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -1084,6 +1084,7 @@ transferIdInfo exported_id local_id where local_info = idInfo local_id transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info + `setTermInfo` termInfo local_info `setCprInfo` cprInfo local_info `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 88b1d34a9e..459d818af6 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -103,8 +103,7 @@ import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) -import GHC.Types.Demand ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Demand ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, topDmd ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique ( hasKey ) @@ -1030,10 +1029,12 @@ annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id -- n_extra are the number of extra value arguments added during floating annotateBotStr id n_extra mb_str = case mb_str of - Nothing -> id - Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdStrictness` (prependArgsStrictSig n_extra sig) - `setIdCprInfo` mkCprSig (arity + n_extra) botCpr + Nothing -> id + Just (_arity, sig) -> ASSERT( arg_dmds `lengthIs` _arity ) + id `setDivergingIdInfo` new_arg_dmds + where + (arg_dmds, _div) = splitStrictSig sig + new_arg_dmds = replicate n_extra topDmd ++ arg_dmds notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 97173eee5c..a04e6b8ae2 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -43,7 +43,8 @@ import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey ) import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold @@ -537,6 +538,7 @@ prepareBinding env top_lvl old_bndr bndr rhs where info = idInfo bndr worker_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info + `setTermInfo` termInfo info `setCprInfo` cprInfo info `setDemandInfo` demandInfo info `setInlinePragInfo` inlinePragInfo info @@ -816,12 +818,13 @@ addLetBndrInfo new_bndr new_arity_type new_unf = info2 -- Bottoming bindings: see Note [Bottoming bindings] + -- We should use setDivergingIdInfo here, but that won't inherit the 'div' info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig - `setCprInfo` bot_cpr + `setTermInfo` divergeTermSig + `setCprInfo` botCprSig | otherwise = info3 - bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div - bot_cpr = mkCprSig new_arity botCpr + bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div -- Zap call arity info. We have used it by now (via -- `tryEtaExpandRhs`), and the simplifier can invalidate this diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index d90df8f62e..d43cef4564 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -49,7 +49,7 @@ import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) , gopt, hasPprDebug ) import GHC.Driver.Ppr import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) -import GHC.Types.Demand +import GHC.Types.Demand hiding ( Call ) import GHC.Types.Cpr import GHC.Serialized ( deserializeWithData ) import GHC.Utils.Misc diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 46b5d111cf..2445c2efa1 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -26,6 +26,7 @@ import GHC.Driver.Ppr import GHC.Driver.Config import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Types.SourceText import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc @@ -189,10 +190,10 @@ If we have where f is strict in y, we might get a more efficient loop by w/w'ing f. But that would make a new unfolding which would overwrite the old -one! So the function would no longer be INLNABLE, and in particular +one! So the function would no longer be INLINABLE, and in particular will not be specialised at call sites in other modules. -This comes in practice (#6056). +This comes up in practice (#6056). Solution: do the w/w for strictness analysis, but transfer the Stable unfolding to the *worker*. So we will get something like this: @@ -482,7 +483,7 @@ tryWW dflags fam_envs is_rec fn_id rhs -- See Note [Don't w/w inline small non-loop-breaker things] | is_fun && is_eta_exp - = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs + = splitFun dflags fam_envs new_fn_id fn_info wrap_arg_dmds div term_sig cpr_sig rhs | isNonRec is_rec, is_thunk -- See Note [Thunk splitting] = splitThunk dflags fam_envs is_rec new_fn_id rhs @@ -491,24 +492,19 @@ tryWW dflags fam_envs is_rec fn_id rhs = return [ (new_fn_id, rhs) ] where - uf_opts = unfoldingOpts dflags - fn_info = idInfo fn_id - (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) - - cpr_ty = getCprSig (cprInfo fn_info) - -- Arity of the CPR sig should match idArity when it's not a join point. - -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal - cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info - , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) - ct_cpr cpr_ty + uf_opts = unfoldingOpts dflags + fn_info = idInfo fn_id + (wrap_arg_dmds, div) = splitStrictSig (strictnessInfo fn_info) + term_sig = termInfo fn_info + cpr_sig = cprInfo fn_info new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id) -- See Note [Zapping DmdEnv after Demand Analyzer] and -- See Note [Zapping Used Once info WorkWrap] - is_fun = notNull wrap_dmds || isJoinId fn_id + is_fun = notNull wrap_arg_dmds || isJoinId fn_id -- See Note [Don't eta expand in w/w] - is_eta_exp = length wrap_dmds == manifestArity rhs + is_eta_exp = length wrap_arg_dmds == manifestArity rhs is_thunk = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id) && not (isUnliftedType (idType fn_id)) @@ -584,12 +580,12 @@ 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 -> TermSig -> CprSig -> CoreExpr -> UniqSM [(Id, CoreExpr)] -splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs - = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do +splitFun dflags fam_envs fn_id fn_info wrap_arg_dmds div term_sig cpr_sig rhs + = WARN( not (wrap_arg_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_arg_dmds $$ ppr body_term $$ ppr body_cpr) ) do -- The arity should match the signature - stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info + stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_arg_dmds body_term ww_cpr case stuff of Just (work_demands, join_arity, wrap_fn, work_fn) -> do work_uniq <- getUniqueM @@ -630,7 +626,9 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs -- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv - `setIdCprInfo` mkCprSig work_arity work_cpr_info + `setIdTermInfo` work_term_sig + + `setIdCprInfo` work_cpr_sig `setIdDemandInfo` worker_demand @@ -670,17 +668,21 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs -- The arity is set by the simplifier using exprEtaExpandArity -- So it may be more than the number of top-level-visible lambdas - -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, + -- CPR and Term sig describe the fun body, are after applying to idArity args + body_cpr = getSig cpr_sig + body_term = getSig term_sig + -- ww_cpr is the CPR we w/w the body for. Note that we kill it for join points, -- see Note [Don't w/w join points for CPR]. - use_cpr_info | isJoinId fn_id = topCpr - | otherwise = cpr + ww_cpr + | isJoinId fn_id = topCpr + | otherwise = body_cpr -- Even if we don't w/w join points for CPR, we might still do so for -- strictness. In which case a join point worker keeps its original CPR -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker -- doesn't have the CPR property anymore. - work_cpr_info | isJoinId fn_id = cpr - | otherwise = topCpr - + (work_term_sig, work_cpr_sig) + | isJoinId fn_id = (term_sig, cpr_sig) + | otherwise = (topTermSig, topCprSig) mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index e9b6904b9f..df05777c34 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -5,14 +5,14 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} module GHC.Core.Opt.WorkWrap.Utils - ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs - , DataConPatContext(..), wantToUnboxArg - , findTypeShape - , isWorkerSmallEnough - ) -where + ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs + , DataConPatContext(..), wantToUnboxArg, wantToUnboxResult + , findTypeShape + , isWorkerSmallEnough + ) where #include "HsVersions.h" @@ -26,11 +26,12 @@ import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Types.Unbox -import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup - , mkCoreApp, mkCoreLet ) +import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup, unitExpr + , mkCoreApp, mkWildValBinder, mkCoreLet ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Builtin.Types ( tupleDataCon, unboxedUnitTy ) +import GHC.Builtin.Types ( tupleDataCon, unboxedUnitTy, unitTy ) import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet ) @@ -50,12 +51,16 @@ import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Tc.Utils.TcType ( isUnitTy ) import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString import GHC.Data.List.SetOps +import GHC.Data.OrdList -import Control.Applicative ( (<|>) ) +import Control.Monad (zipWithM) +import Control.Applicative ((<|>)) +import Data.List (unzip4) {- ************************************************************************ @@ -151,11 +156,13 @@ type WwResult CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs mkWwBodies :: WwOpts - -> VarSet -- Free vars of RHS + -> VarSet -- ^ Free vars of RHS -- See Note [Freshen WW arguments] - -> Id -- The original function - -> [Demand] -- Strictness of original function - -> CprResult -- Info about function result + -> Id -- ^ The original function + -> [Demand] -- ^ Strictness of original function + -- (derived from 'idStrictness') + -> Term -- ^ Info about function termination + -> Cpr -- ^ Info about function result -> UniqSM (Maybe WwResult) -- wrap_fn_args E = \x y -> E @@ -169,25 +176,25 @@ mkWwBodies :: WwOpts -- let x = (a,b) in -- E -mkWwBodies opts rhs_fvs fun_id demands cpr_info +mkWwBodies opts rhs_fvs fun_id arg_dmds body_term body_cpr = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) -- See Note [Freshen WW arguments] ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs empty_subst fun_ty demands + <- mkWWargs empty_subst fun_ty arg_dmds ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr opts arg_ubx_strat wrap_args -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr opts ret_ubx_strat res_ty cpr_info + <- mkWWcpr_start opts ret_ubx_strat res_ty body_term body_cpr ; let (work_lam_args, work_call_args) = mkWorkerArgs (wo_fun_to_thunk opts) work_args cpr_res_ty worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args - ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args + ; if isWorkerSmallEnough (wo_max_worker_args opts) (length arg_dmds) work_args && not (too_many_args_for_join_point wrap_args) && ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, @@ -210,12 +217,12 @@ mkWwBodies opts rhs_fvs fun_id demands cpr_info has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id) -- See Note [Do not unpack class dictionaries] - ret_ubx_strat :: UnboxingStrategy CprResult + ret_ubx_strat :: UnboxingStrategy Cpr ret_ubx_strat = wantToUnboxResult (wo_fam_envs opts) -- Note [Do not split void functions] only_one_void_argument - | [d] <- demands + | [d] <- arg_dmds , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty , isAbsDmd d && isVoidTy arg_ty1 = True @@ -246,9 +253,9 @@ isWorkerSmallEnough max_worker_args old_n_args vars Note [Always do CPR w/w] ~~~~~~~~~~~~~~~~~~~~~~~~ At one time we refrained from doing CPR w/w for thunks, on the grounds that -we might duplicate work. But that is already handled by the demand analyser, +we might duplicate work. But that is already handled by CPR analysis, which doesn't give the CPR property if w/w might waste work: see -Note [CPR for thunks] in GHC.Core.Opt.DmdAnal. +Note [CPR for thunks] in GHC.Core.Opt.CprAnal. And if something *has* been given the CPR property and we don't w/w, it's a disaster, because then the enclosing function might say it has the CPR @@ -581,12 +588,12 @@ wantToUnboxArg fam_envs has_inlineable_prag ty dmd -- | 'UnboxingStrategy' for constructed results -wantToUnboxResult :: FamInstEnvs -> UnboxingStrategy CprResult +wantToUnboxResult :: FamInstEnvs -> UnboxingStrategy Cpr -- See Note [Which types are unboxed?] wantToUnboxResult fam_envs ty cpr - | Just con_tag <- asConCpr cpr + | Just (con_tag, arg_cprs) <- asConCpr cpr , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty - , isDataTyCon tc -- NB: No unboxed sums or tuples + -- See Note [non-algebraic or open body type warning] , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning , dcs `lengthAtLeast` con_tag -- This might not be true if we import the -- type constructor via a .hs-boot file (#8743) @@ -599,7 +606,7 @@ wantToUnboxResult fam_envs ty cpr -- Deactivates CPR worker/wrapper splits on constructors with non-linear -- arguments, for the moment, because they require unboxed tuple with variable -- multiplicity fields. - = Unbox (DataConPatContext dc tc_args co) [] + = Unbox (DataConPatContext dc tc_args co) arg_cprs | otherwise = StopUnboxing @@ -613,7 +620,118 @@ isLinear (Scaled w _ ) = One -> True _ -> False -{- +{- 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_start'. + + 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 xopts want_to_unbox = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) + +The respective tests are in 'wantToUnboxArg' and +'wantToUnboxResult', 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 +strict *and* used demand put on it. I.e., arguments, with demands such +as the following ones: + + <S,U(U, L)> + <S(L,S),U> + +will be unpacked, but + + <S,U> or <B,U> + +will not, because the pieces aren't used. This is quite important otherwise +we end up unpacking massive tuples passed to the bottoming function. Example: + + f :: ((Int,Int) -> String) -> (Int,Int) -> a + f g pr = error (g pr) + + main = print (f fst (1, error "no")) + +Does 'main' print "error 1" or "error no"? We don't really want 'f' +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 [non-algebraic or open body type warning] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a few cases where the W/W transformation is told that something +returns a constructor, but the type at hand doesn't really match this. One +real-world example involves unsafeCoerce: + foo = IO a + foo = unsafeCoerce c_exit + foreign import ccall "c_exit" c_exit :: IO () +Here CPR will tell you that `foo` returns a () constructor for sure, but trying +to create a worker/wrapper for type `a` obviously fails. +(This was a real example until ee8e792 in libraries/base.) + +It does not seem feasible to avoid all such cases already in the analyser (and +after all, the analysis is not really wrong), so we simply do nothing here in +mkWWcpr_one. But we still want to emit warning with -DDEBUG, to hopefully catch +other cases where something went avoidably wrong. + +This warning also triggers for the stream fusion library within `text`. +We can'easily W/W constructed results like `Stream` because we have no simple +way to express existential types in the worker's type signature. + ************************************************************************ * * \subsection{Strictness stuff} @@ -647,42 +765,13 @@ mkWWstr opts want_to_unbox args , wrap_fn1 . wrap_fn2 , work_fn1 . work_fn2) } -{- -Note [Unpacking arguments with product and polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The argument is unpacked in a case if it has a product type and has a -strict *and* used demand put on it. I.e., arguments, with demands such -as the following ones: - - <S,U(U, L)> - <S(L,S),U> - -will be unpacked, but - - <S,U> or <B,U> - -will not, because the pieces aren't used. This is quite important otherwise -we end up unpacking massive tuples passed to the bottoming function. Example: - - f :: ((Int,Int) -> String) -> (Int,Int) -> a - f g pr = error (g pr) - - main = print (f fst (1, error "no")) - -Does 'main' print "error 1" or "error no"? We don't really want 'f' -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. --} - ---------------------- -- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) -- * wrap_fn assumes wrap_arg is in scope, -- brings into scope work_args (via cases) --- * work_fn assumes work_args are in scope, a +-- * work_fn assumes work_args are in scope, -- brings into scope wrap_arg (via lets) --- See Note [How to do the worker/wrapper split] +-- See Note [Worker/wrapper for Strictness and Absence] mkWWstr_one :: WwOpts -> UnboxingStrategy Demand -> Var @@ -698,30 +787,30 @@ mkWWstr_one opts want_to_unbox arg = -- (that's what mk_absent_let does) -> return (True, [], nop_fn, work_fn) - Unbox dcpc cs -> unbox_one opts want_to_unbox arg cs dcpc + Unbox dcpc cs -> unbox_one_arg opts want_to_unbox arg cs dcpc _ -> do_nothing -- Other cases, like StopUnboxing where do_nothing = return (False, [arg], nop_fn, nop_fn) -unbox_one :: WwOpts +unbox_one_arg :: WwOpts -> UnboxingStrategy Demand -> Var -> [Demand] -> DataConPatContext -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -unbox_one opts want_to_unbox arg cs +unbox_one_arg opts want_to_unbox arg cs DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co } - = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM - ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc + = do { pat_bndrs_uniqs <- getUniquesM + ; 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' - unbox_fn = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq + arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids cs' + unbox_fn = mkUnpackCase (Var arg) co (idMult arg) dc (ex_tvs' ++ arg_ids') arg_no_unf = zapStableUnfolding arg -- See Note [Zap unfolding when beta-reducing] @@ -745,8 +834,8 @@ addDataConStrictness con ds add dmd str | isMarkedStrict str = strictifyDmd dmd | otherwise = dmd -{- Note [How to do the worker/wrapper split] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Worker/wrapper for Strictness and Absence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The worker-wrapper transformation, mkWWstr_one, takes into account several possibilities to decide if the function is worthy for splitting: @@ -857,7 +946,7 @@ So here's what we do * 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]. + Note [Worker/wrapper for Strictness and Absence]. The net effect is that the w/w transformation is more aggressive about unpacking the strict arguments of a data constructor, when that @@ -933,81 +1022,11 @@ 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 - - data T = MkT !Int Int - - f :: T -> T - f x = e - -and f's is strict, and has the CPR property. The we are going to generate -this w/w split - - f x = case x of - MkT x1 x2 -> case $wf x1 x2 of - (# r1, r2 #) -> MkT r1 r2 - - $wfw x1 x2 = let x = MkT x1 x2 in - case e of - MkT r1 r2 -> (# r1, r2 #) - -Note that - -* In the worker $wf, inside 'e' we can be sure that x1 will be - evaluated (it came from unpacking the argument MkT. But that's no - immediately apparent in $wf - -* In the wrapper 'f', which we'll inline at call sites, we can be sure - that 'r1' has been evaluated (because it came from unpacking the result - MkT. But that is not immediately apparent from the wrapper code. - -Missing these facts isn't unsound, but it loses possible future -opportunities for optimisation. - -Solution: use setCaseBndrEvald when creating - (A) The arg binders x1,x2 in mkWstr_one - See #13077, test T13077 - (B) The result binders r1,r2 in mkWWcpr_help - See Trace #13077, test T13077a - And #13027 comment:20, item (4) -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. -} findTypeShape :: FamInstEnvs -> Type -> TypeShape @@ -1068,164 +1087,279 @@ 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} * * ************************************************************************ - - -@mkWWcpr@ takes the worker/wrapper pair produced from the strictness -info and adds in the CPR transformation. The worker returns an -unboxed tuple containing non-CPR components. The wrapper takes this -tuple and re-produces the correct structured output. - -The non-CPR results appear ordered in the unboxed tuple as if by a -left-to-right traversal of the result structure. -} -mkWWcpr :: WwOpts - -> UnboxingStrategy CprResult - -> Type -- function body type - -> CprResult -- CPR analysis results - -> UniqSM (Bool, -- Is w/w'ing useful? - CoreExpr -> CoreExpr, -- New wrapper - CoreExpr -> CoreExpr, -- New worker - Type) -- Type of worker's body - -mkWWcpr opts want_to_unbox body_ty cpr = case want_to_unbox body_ty cpr of - Unbox dcpc _arg_cprs -- not nestedly (yet) - | wo_cpr_anal opts -> mkWWcpr_help dcpc - _ -> return (False, id, id, body_ty) -- No CPR info - -mkWWcpr_help :: DataConPatContext - -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) - -mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args - , dcpc_co = co }) - | ASSERT2( null (dataConExTyCoVars dc), ppr dc ) True - -- No existentials! Should have been caught in 'wantToUnboxResult' - , [arg_ty] <- dataConInstArgTys dc tc_args - , [str_mark] <- dataConRepStrictness dc - , isUnliftedType (scaledThing arg_ty) - , isLinear arg_ty - -- Special case when there is a single result of unlifted, linear, type - -- - -- Wrapper: case (..call worker..) of x -> C x - -- Worker: case ( ..body.. ) of C x -> x - = do { (work_uniq : arg_uniq : _) <- getUniquesM - ; let arg_id = mk_ww_local arg_uniq str_mark arg_ty - con_app = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co - - ; return ( True - , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app - , \ body -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id) - -- varToCoreExpr important here: arg can be a coercion - -- Lacking this caused #10658 - , scaledThing arg_ty ) } - - | otherwise -- The general case - -- Wrapper: case (..call worker..) of (# a, b #) -> C a b - -- Worker: case ( ...body... ) of C a b -> (# a, b #) - -- - -- Remark on linearity: in both the case of the wrapper and the worker, - -- we build a linear case. All the multiplicity information is kept in - -- the constructors (both C and (#, #)). In particular (#,#) is - -- parametrised by the multiplicity of its fields. Specifically, in this - -- instance, the multiplicity of the fields of (#,#) is chosen to be the - -- same as those of C. - = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM - ; let case_mult = One -- see above - (_exs, arg_ids) = - dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args - wrap_wild = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty) - ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids) - con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co - tup_con = tupleDataCon Unboxed (length arg_ids) - - ; MASSERT( null _exs ) -- Should have been caught by wantToUnboxResult - - ; return (True - , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild - (DataAlt tup_con) arg_ids con_app - , \ body -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app - , ubx_tup_ty ) } - -mkUnpackCase :: CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr --- (mkUnpackCase e co uniq Con args body) --- returns --- case e |> co of bndr { Con args -> body } - -mkUnpackCase (Tick tickish e) co mult uniq con args body -- See Note [Profiling and unpacking] - = Tick tickish (mkUnpackCase e co mult uniq con args body) -mkUnpackCase scrut co mult uniq boxing_con unpk_args body - = mkSingleAltCase casted_scrut bndr - (DataAlt boxing_con) unpk_args body +mkWWcpr_start + :: WwOpts + -> UnboxingStrategy Cpr + -> Type -- function body + -> Term -- Termination analysis results + -> Cpr -- CPR analysis results + -> UniqSM (Bool, -- Is w/w'ing useful? + CoreExpr -> CoreExpr, -- New wrapper + CoreExpr -> CoreExpr, -- New worker + Type) -- Type of worker's body +-- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview. +mkWWcpr_start opts want_to_unbox body_ty body_term body_cpr + | not (wo_cpr_anal opts) = return (False, id, id, body_ty) + | otherwise = do + -- Part (1) + res_bndr <- mk_res_bndr body_ty body_term + let bind_res_bndr body scope = mkDefaultCase body res_bndr scope + deref_res_bndr = Var res_bndr + + -- Part (2) + (useful, fromOL -> transit_vars, wrap_build_res, work_unpack_res) <- + mkWWcpr_one opts want_to_unbox res_bndr body_cpr + + -- Part (3) + let (unbox_transit_tup, transit_tup) = move_transit_vars transit_vars + + -- Stacking unboxer (work_fn) and builder (wrap_fn) together + let wrap_fn = unbox_transit_tup (wrap_build_res deref_res_bndr) -- 3 2 1 + work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3 + work_body_ty = exprType transit_tup + -- It wasn't useful if both worker and wrapper return () anyway + -- See Note [Lifted, empty tuple when no transit vars] + useful' = useful && not (isUnitTy body_ty && isUnitTy work_body_ty) + return $ if not useful' + then (False, nop_fn, nop_fn, body_ty) + else (True, wrap_fn, work_fn, work_body_ty) where - casted_scrut = scrut `mkCast` co - bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut)) - -- An unpacking case can always be chosen linear, because the variables - -- are always passed to a constructor. This limits the -{- -Note [non-algebraic or open body type warning] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a few cases where the W/W transformation is told that something -returns a constructor, but the type at hand doesn't really match this. One -real-world example involves unsafeCoerce: - foo = IO a - foo = unsafeCoerce c_exit - foreign import ccall "c_exit" c_exit :: IO () -Here CPR will tell you that `foo` returns a () constructor for sure, but trying -to create a worker/wrapper for type `a` obviously fails. -(This was a real example until ee8e792 in libraries/base.) - -It does not seem feasible to avoid all such cases already in the analyser (and -after all, the analysis is not really wrong), so we simply do nothing here in -mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch -other cases where something went avoidably wrong. + mk_res_bndr :: Type -> Term -> UniqSM Id + mk_res_bndr body_ty body_term = do + -- See Note [Linear types and CPR] + bndr <- mkSysLocalOrCoVarM ww_prefix cprCaseBndrMult body_ty + -- See Note [Record evaluated-ness in worker/wrapper] + let (_tf, body_term') = forceTerm topSubDmd body_term + pure $ setCaseBndrEvald MarkedStrict bndr + `setIdTermInfo` Sig body_term' -- so that we see that it terminates + +-- | What part (2) of Note [Worker/wrapper for CPR] collects. +-- +-- 1. A 'Bool' capturing whether the transformation did anything useful. +-- 2. The list of transit variables (see the Note). +-- 3. The result builder expression for the wrapper +-- 4. The result unpacking expression for the worker +type CprWwResult = (Bool, OrdList Var, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) + +mkWWcpr :: WwOpts -> UnboxingStrategy Cpr -> [Id] -> [Cpr] -> UniqSM CprWwResult +mkWWcpr opts want_to_unbox vars cprs = do + -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that. + MASSERT2( not (any isTyVar vars), ppr vars $$ ppr cprs ) + MASSERT2( equalLength vars cprs, ppr vars $$ ppr cprs ) + (usefuls, varss, wrap_build_ress, work_unpack_ress) <- + unzip4 <$> zipWithM (mkWWcpr_one opts want_to_unbox) vars cprs + return ( or usefuls + , concatOL varss + , foldl' (.) id wrap_build_ress + , foldl' (.) id work_unpack_ress ) + +mkWWcpr_one :: WwOpts -> UnboxingStrategy Cpr -> Id -> Cpr -> UniqSM CprWwResult +-- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. +mkWWcpr_one opts want_to_unbox res_bndr cpr + | ASSERT( not (isTyVar res_bndr) ) True + , Unbox dcpc arg_cprs <- want_to_unbox (idType res_bndr) cpr + = unbox_one_result opts want_to_unbox res_bndr arg_cprs dcpc + | otherwise + = return (False, unitOL res_bndr, nop_fn, nop_fn) + +unbox_one_result + :: WwOpts -> UnboxingStrategy Cpr -> Id -> [Cpr] -> DataConPatContext + -> UniqSM CprWwResult +-- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR] +unbox_one_result opts want_to_unbox res_bndr arg_cprs + DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co } = do + -- unboxer (free in `res_bndr`): | builder (binds `res_bndr`): + -- ( case res_bndr of (i, j) -> ) | ( let j = I# b in ) + -- ( case i of I# a -> ) | ( let i = I# a in ) + -- ( case j of I# b -> ) | ( let res_bndr = (i, j) in ) + -- ( <hole> ) | ( <hole> ) + pat_bndrs_uniqs <- getUniquesM + let (_exs, arg_ids) = + dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args + MASSERT( null _exs ) -- Should have been caught by wantToUnboxResult + + let -- transfer termination info to field binders + arg_terms = expandConFieldsTerm dc (getSig $ idTermInfo res_bndr) + arg_ids' = zipWithEqual "unbox_one_result" (flip setIdTermInfo . Sig) arg_terms arg_ids + -- con_app = (C a b |> sym co) + con_app = mkConApp2 dc tc_args arg_ids' `mkCast` mkSymCo co + -- this_wrap_build_res body = (let res_bndr = C a b |> sym co in <body>[r]) + this_wrap_build_res = Let (NonRec res_bndr con_app) + -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b]) + this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids' + + (nested_useful, transit_vars, wrap_build_res, work_unbox_res) <- + mkWWcpr opts want_to_unbox arg_ids' arg_cprs + + -- Don't try to WW an unboxed tuple return type when there's nothing inside + -- to unbox further. + return $ if isUnboxedTupleDataCon dc && not nested_useful + then ( False, unitOL res_bndr, nop_fn, nop_fn ) + else ( True + , transit_vars + , wrap_build_res . this_wrap_build_res + , this_work_unbox_res . work_unbox_res + ) + +-- | Implements part (3) of Note [Worker/wrapper for CPR]. +-- +-- If `move_transit_vars [a,b] = (unbox, tup)` then +-- * `a` and `b` are the *transit vars* to be returned from the worker +-- to the wrapper +-- * `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)` +-- * `tup = (# a, b #)` +-- There are two special cases for when there's 0 or 1 transit var, +-- respectively. See Note [Lifted, empty tuple when no transit vars] +-- and Note [No unboxed tuple for single, unlifted transit var] +move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr) +move_transit_vars vars + | [] <- vars + , let case_bndr = mkWildValBinder cprCaseBndrMult unitTy + -- See Note [Lifted, empty tuple when no transit vars] + -- * Wrapper: `unbox scrut alt = (case <scrut> of _ -> <alt>)` + -- * Worker: `tup = ()` + = ( \build_res wkr_call -> mkDefaultCase wkr_call case_bndr build_res + , unitExpr ) + + | [var] <- vars + , let var_ty = idType var + , isUnliftedType var_ty || whnf_term var + -- See Note [No unboxed tuple for single, unlifted transit var] + -- * Wrapper: `unbox scrut alt = (case <scrut> of a -> <alt>)` + -- * Worker: `tup = a` + = ( \build_res wkr_call -> mkDefaultCase wkr_call var build_res + , varToCoreExpr var ) -- varToCoreExpr important here: var can be a coercion + -- Lacking this caused #10658 + | otherwise + -- The general case: Just return an unboxed tuple from the worker + -- * Wrapper: `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)` + -- * Worker: `tup = (# a, b #)` + = ( \build_res wkr_call -> mkSingleAltCase wkr_call case_bndr + (DataAlt tup_con) vars build_res + , ubx_tup_app ) + where + -- | Whether Termination analysis says that `v` terminates quickly + whnf_term v = whnfTerminatesRapidly $ getSig $ idTermInfo $ v + ubx_tup_app = mkCoreUbxTup (map idType vars) (map varToCoreExpr vars) + tup_con = tupleDataCon Unboxed (length vars) + -- See also Note [Linear types and CPR] + case_bndr = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app) + + +{- Note [Worker/wrapper for CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'mkWWcpr_start' is the entry-point to the worker/wrapper transformation that +exploits CPR info. Here's an example: +``` + f :: ... -> (Int, Int) + f ... = <body> +``` +Let's assume the CPR info `body_cpr` for the body of `f` says +"unbox the pair and its components" and `body_ty` is the type of the function +body `body` (i.e., `(Int, Int)`). Then `mkWWcpr_start body_ty body_cpr` returns + + * A result-unpacking expression for the worker, with a hole for the fun body: + ``` + unpack body = ( case <body> of r __DEFAULT -> ) -- (1) + ( case r of (i, j) -> ) -- (2) + ( case i of I# a -> ) -- (2) + ( case j of I# b -> ) -- (2) + ( (# a, b #) ) -- (3) + ``` + * A result-building expression for the wrapper, with a hole for the worker call: + ``` + build wkr_call = ( case <wkr_call> of (# a, b #) -> ) -- (3) + ( let j = I# b in ) -- (2) + ( let i = I# a in ) -- (2) + ( let r = (i, j) in ) -- (2) + ( r ) -- (1) + ``` + * The result type of the worker, e.g., `(# Int#, Int# #)` above. + +To achieve said transformation, 'mkWWcpr_start' + + 1. First allocates a fresh result binder `r`, giving a name to the `body` + expression and contributing part (1) of the unpacker and builder. + 2. Then it delegates to 'mkWWcpr_one', which recurses into all result fields + to unbox, contributing the parts marked with (2). Crucially, it knows + what belongs in the case scrutinee through the communicated Id `r`: The + unpacking expression will be free in that variable. + (This is a similar contract as that of 'mkWWstr_one' for strict args.) + 3. 'mkWWstr_one' produces a bunch of *transit vars*: Those result variables + that have to be transferred from the worker to the wrapper, where the + constructed result can be rebuild, `a` and `b` above. Part (3) is + responsible for tupling them up in the worker and taking the tuple apart + in the wrapper. This is implemented in 'move_transit_vars'. + +Note [Lifted, empty tuple when no transit vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the case when there are no transit vars, e.g.: +``` + trueAllAlong xs = case xs of + [] -> True + x:xs -> x `seq` force xs + ==> { CPR+WW } + trueAllAlong xs = case $wtrueAllAlong xs of (# #) -> True + $wtrueAllAlong xs = case xs of + [] -> (# #) + x:xs -> x `seq` force xs +``` +Here, instead of passing around the *unboxed* empty unit tuple `(# #)`, we +simply return the *boxed* empty unit tuple `()`, simply because it's easier +on the eye. There's no difference because we end up evaluating it anyway in +the case expression of the wrapper `trueAllAlong`. + +Note [No unboxed tuple for single, unlifted transit var] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there's only a single, unlifted transit var (Note [Worker/wrapper for CPR]), +we don't wrap an unboxed singleton tuple around it (which otherwise would be +needed to suspend evaluation) and return the unlifted thing directly. E.g. +``` + f :: Int -> Int + f x = x+1 +``` +We certainly want `$wf :: Int# -> Int#`, not `$wf :: Int# -> (# Int# #)`. +This is OK as long as we know that evaluation of the returned thing terminates +quickly, as is the case for fields of unlifted type like `Int#`. + +But more generally, this is also true for *lifted* types that terminate quickly! +Consider from `T18109`: +``` + data F = F (Int -> Int) + f :: Int -> F + f n = F (+n) + + data T = T (Int, Int) + g :: T -> T + g t@(T p) = p `seq` t + + data U = U ![Int] + h :: Int -> U + h n = U [0..n] +``` +Both worker should not wrap the fields in singleton tuples, because they are +already evaluated. For `g`, we manage not to by looking at the termination +information of `p`, which reflects that it has been seq'd. +For `f`, rapid termination analysis should see that `(+n)` terminates rapidly +and thus omit the singleton tuple. +For `h`, we also have to consider the strictness of the field, but in contrast +to Note [Add demands for strict constructors], that may already happen in +'cprTransformDataConWork', so the CPR info should reflect that. -This warning also triggers for the stream fusion library within `text`. -We can'easily W/W constructed results like `Stream` because we have no simple -way to express existential types in the worker's type signature. +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ Note [Profiling and unpacking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1245,12 +1379,14 @@ eliminate the case, and the scc would get in the way? I'm ok with including the case itself in the cost centre, since it is morally part of the function (post transformation) anyway. - -************************************************************************ -* * -\subsection{Utilities} -* * -************************************************************************ +Note [Linear types and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Remark on linearity: in both the case of the wrapper and the worker, +we build a linear case to unpack constructed products. All the +multiplicity information is kept in the constructors (both C and (#, #)). +In particular (#,#) is parametrised by the multiplicity of its fields. +Specifically, in this instance, the multiplicity of the fields of (#,#) +is chosen to be the same as those of C. Note [Absent errors] ~~~~~~~~~~~~~~~~~~~~ @@ -1333,8 +1469,68 @@ fragile ...f (MkT a (absentError Int# "blah"))... because `MkT` is strict in its Int# argument, so we get an absentError exception when we shouldn't. Very annoying! + +Note [Record evaluated-ness in worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + data T = MkT !Int Int + + f :: T -> T + f x = e + +and f's is strict, and has the CPR property. The we are going to generate +this w/w split + + f x = case x of + MkT x1 x2 -> case $wf x1 x2 of + (# r1, r2 #) -> MkT r1 r2 + + $wfw x1 x2 = let x = MkT x1 x2 in + case e of + MkT r1 r2 -> (# r1, r2 #) + +Note that + +* In the worker $wf, inside 'e' we can be sure that x1 will be + evaluated (it came from unpacking the argument MkT. But that's no + immediately apparent in $wf + +* In the wrapper 'f', which we'll inline at call sites, we can be sure + that 'r1' has been evaluated (because it came from unpacking the result + MkT. But that is not immediately apparent from the wrapper code. + +Missing these facts isn't unsound, but it loses possible future +opportunities for optimisation. + +Solution: use setCaseBndrEvald when creating + (A) The arg binders x1,x2 in mkWstr_one + See #13077, test T13077 + (B) The result binders r1,r2 in mkWWcpr_one_help + See Trace #13077, test T13077a + And #13027 comment:20, item (4) +to record that the relevant binder is evaluated. + -} +mkUnpackCase :: CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr +-- (mkUnpackCase e co Con args body) +-- returns +-- case e |> co of _dead { Con args -> body } +mkUnpackCase (Tick tickish e) co mult con args body -- See Note [Profiling and unpacking] + = Tick tickish (mkUnpackCase e co mult con args body) +mkUnpackCase scrut co mult boxing_con unpk_args body + = mkSingleAltCase casted_scrut bndr + (DataAlt boxing_con) unpk_args body + where + casted_scrut = scrut `mkCast` co + bndr = mkWildValBinder mult (exprType casted_scrut) + +-- | The multiplicity of a case binder unboxing a constructed result. +-- See Note [Linear types and CPR] +cprCaseBndrMult :: Mult +cprCaseBndrMult = One + -- | Tries to find a suitable dummy RHS to bind the given absent identifier to. -- -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding @@ -1366,7 +1562,7 @@ mk_absent_let opts arg dmd = WARN( True, text "No absent value for" <+> ppr arg_ty ) Nothing -- Can happen for 'State#' and things of 'VecRep' where - lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr + lifted_arg = arg `setDivergingIdInfo` [] -- Note in strictness signature that this is bottoming -- (for the sake of the "empty case scrutinee not known to -- diverge for sure lint" warning) @@ -1402,11 +1598,3 @@ mk_absent_let opts arg dmd ww_prefix :: FastString ww_prefix = fsLit "ww" - -mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id --- The StrictnessMark comes form the data constructor and says --- whether this field is strict --- See Note [Record evaluated-ness in worker/wrapper] -mk_ww_local uniq str (Scaled w ty) - = setCaseBndrEvald str $ - mkSysLocalOrCoVar ww_prefix uniq w ty diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index ddfa2ea2a6..3663110ba9 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -27,6 +27,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.TyCo.Ppr @@ -473,6 +474,8 @@ instance Outputable IdInfo where , (has_called_arity, text "CallArity=" <> int called_arity) , (has_caf_info, text "Caf=" <> ppr caf_info) , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_term_info, text "Term=" <> ppr term_info) + , (has_cpr_info, text "Cpr=" <> ppr cpr_info) , (has_unf, text "Unf=" <> ppr unf_info) , (has_rules, text "RULES:" <+> vcat (map pprRule rules)) ] @@ -501,6 +504,12 @@ instance Outputable IdInfo where str_info = strictnessInfo info has_str_info = not (isTopSig str_info) + term_info = termInfo info + has_term_info = term_info /= topTermSig + + cpr_info = cprInfo info + has_cpr_info = cpr_info /= topCprSig + unf_info = unfoldingInfo info has_unf = hasSomeUnfolding unf_info @@ -522,6 +531,7 @@ ppIdInfo id info , (has_called_arity, text "CallArity=" <> int called_arity) , (has_caf_info, text "Caf=" <> ppr caf_info) , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_term_info, text "Term=" <> ppr term_info) , (has_cpr_info, text "Cpr=" <> ppr cpr_info) , (has_unf, text "Unf=" <> ppr unf_info) , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) @@ -545,6 +555,9 @@ ppIdInfo id info str_info = strictnessInfo info has_str_info = not (isTopSig str_info) + term_info = termInfo info + has_term_info = term_info /= topTermSig + cpr_info = cprInfo info has_cpr_info = cpr_info /= topCprSig diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 4dafc9c2e8..02a8cd61c1 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -16,6 +16,7 @@ import GHC.Core import GHC.Types.Id.Info import GHC.Types.Demand( seqDemand, seqStrictSig ) import GHC.Types.Cpr( seqCprSig ) +import GHC.Types.Termination ( seqTermSig ) import GHC.Types.Basic( seqOccInfo ) import GHC.Types.Var.Set( seqDVarSet ) import GHC.Types.Var( varType, tyVarKind ) @@ -35,6 +36,7 @@ megaSeqIdInfo info seqDemand (demandInfo info) `seq` seqStrictSig (strictnessInfo info) `seq` + seqTermSig (termInfo info) `seq` seqCprSig (cprInfo info) `seq` seqCaf (cafInfo info) `seq` seqOneShot (oneShotInfo info) `seq` diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 8c18a13eb6..a3204fa0aa 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -77,6 +77,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Tidy ( tidyCo ) import GHC.Types.Demand ( isTopSig ) import GHC.Types.Cpr ( topCprSig ) +import GHC.Types.Termination ( topTermSig ) import Data.Maybe ( catMaybes ) @@ -449,8 +450,8 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo id_info - = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo, - inline_hsinfo, unfold_hsinfo, levity_hsinfo] + = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, term_hsinfo, cpr_hsinfo, + inline_hsinfo, unfold_hsinfo, levity_hsinfo] -- NB: strictness and arity must appear in the list before unfolding -- See GHC.IfaceToCore.tcUnfolding where @@ -471,10 +472,16 @@ toIfaceIdInfo id_info strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) | otherwise = Nothing + ------------ Termination -------------- + term_info = termInfo id_info + term_hsinfo | term_info /= topTermSig = Just (HsTerm term_info) + | otherwise = Nothing + ------------ CPR -------------- cpr_info = cprInfo id_info cpr_hsinfo | cpr_info /= topCprSig = Just (HsCpr cpr_info) | otherwise = Nothing + ------------ Unfolding -------------- unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) loop_breaker = isStrongLoopBreaker (occInfo id_info) diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs index ac9c687b62..202167dbb2 100644 --- a/compiler/GHC/Data/Maybe.hs +++ b/compiler/GHC/Data/Maybe.hs @@ -22,7 +22,7 @@ module GHC.Data.Maybe ( rightToMaybe, -- * MaybeT - MaybeT(..), liftMaybeT, tryMaybeT + MaybeT(..), liftMaybeT, hoistMaybe, tryMaybeT ) where import GHC.Prelude @@ -91,6 +91,10 @@ rightToMaybe (Right x) = Just x liftMaybeT :: Monad m => m a -> MaybeT m a liftMaybeT act = MaybeT $ Just `liftM` act +-- | Hoist a 'Maybe' into a 'MaybeT' +hoistMaybe :: Applicative f => Maybe a -> MaybeT f a +hoistMaybe = MaybeT . pure + -- | Try performing an 'IO' action, failing on error. tryMaybeT :: IO a -> MaybeT IO a tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 3d0908caa0..8254a6517e 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -197,6 +197,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 diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 85f1b71852..8206653ae2 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3966,6 +3966,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) diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 73e8525589..e97299f171 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -52,6 +52,7 @@ import GHC.Iface.Recomp.Binary import GHC.Core( IsOrphan, isOrphan ) import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Core.Class import GHC.Types.FieldLabel import GHC.Types.Name.Set @@ -349,6 +350,7 @@ type IfaceIdInfo = [IfaceInfoItem] data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig + | HsTerm TermSig | HsCpr CprSig | HsInline InlinePragma | HsUnfold Bool -- True <=> isStrongLoopBreaker is true @@ -1466,6 +1468,7 @@ instance Outputable IfaceInfoItem where ppr (HsInline prag) = text "Inline:" <+> ppr prag ppr (HsArity arity) = text "Arity:" <+> int arity ppr (HsStrictness str) = text "Strictness:" <+> ppr str + ppr (HsTerm term) = text "Term:" <+> ppr term ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr ppr HsNoCafRefs = text "HasNoCafRefs" ppr HsLevity = text "Never levity-polymorphic" @@ -2233,6 +2236,7 @@ instance Binary IfaceInfoItem where put_ bh HsLevity = putByte bh 5 put_ bh (HsCpr cpr) = putByte bh 6 >> put_ bh cpr put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info + put_ bh (HsTerm cpr) = putByte bh 8 >> put_ bh cpr get bh = do h <- getByte bh @@ -2246,7 +2250,9 @@ instance Binary IfaceInfoItem where 4 -> return HsNoCafRefs 5 -> return HsLevity 6 -> HsCpr <$> get bh - _ -> HsLFInfo <$> get bh + 7 -> HsLFInfo <$> get bh + 8 -> HsTerm <$> get bh + _ -> pprPanic "Binary IfaceInfoItem: Invalid tag" (int (fromIntegral h)) instance Binary IfaceUnfolding where put_ bh (IfCoreUnfold s e) = do @@ -2586,8 +2592,9 @@ instance NFData IfaceInfoItem where HsUnfold b unf -> rnf b `seq` rnf unf HsNoCafRefs -> () HsLevity -> () - HsCpr cpr -> cpr `seq` () + HsCpr cpr -> seqCprSig cpr `seq` () HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further? + HsTerm term -> seqTermSig term `seq` () instance NFData IfaceUnfolding where rnf = \case diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index dedfd1772b..3b9c5f9069 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -60,7 +60,8 @@ import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Types.Basic import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set @@ -1203,6 +1204,7 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold = vanillaIdInfo `setArityInfo` arity `setStrictnessInfo` final_sig + `setTermInfo` final_term `setCprInfo` final_cpr `setOccInfo` robust_occ_info `setInlinePragInfo` (inlinePragInfo idinfo) @@ -1220,6 +1222,7 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold --------- Strictness ------------ mb_bot_str = exprBotStrictness_maybe orig_rhs + -- final_* should agree with setDivergingInfo sig = strictnessInfo idinfo final_sig | not $ isTopSig sig = WARN( _bottom_hidden sig , ppr name ) sig @@ -1227,11 +1230,13 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold | Just (_, nsig) <- mb_bot_str = nsig | otherwise = sig + term = termInfo idinfo cpr = cprInfo idinfo - final_cpr | Just _ <- mb_bot_str - = mkCprSig arity botCpr - | otherwise - = cpr + (final_term, final_cpr) + | Just _ <- mb_bot_str + = (divergeTermSig, botCprSig) + | otherwise + = (term, cpr) _bottom_hidden id_sig = case mb_bot_str of Nothing -> False diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 862112060c..0d3fe59212 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1617,6 +1617,7 @@ tcIdInfo ignore_prags toplvl name ty info = do tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) + tcPrag info (HsTerm term) = return (info `setTermInfo` term) tcPrag info (HsCpr cpr) = return (info `setCprInfo` cpr) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) tcPrag info HsLevity = return (info `setNeverLevPoly` ty) diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 314e010ead..ebf0ae22cd 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -329,7 +329,7 @@ tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body) rhsCard :: Id -> Card rhsCard bndr | is_thunk = oneifyCard n - | otherwise = peelManyCalls (idArity bndr) cd + | otherwise = fst $ peelManyCalls (idArity bndr) cd where is_thunk = idArity bndr == 0 -- Let's pray idDemandInfo is still OK after unarise... diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs index a884091cef..f0097d01ad 100644 --- a/compiler/GHC/Types/Cpr.hs +++ b/compiler/GHC/Types/Cpr.hs @@ -1,163 +1,309 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} --- | 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'. +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | 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, botCpr, topCpr, lubCpr, appCpr, lamCpr, asConCpr, + expandConFieldsCpr, pruneDeepCpr, dropNonBotCpr, + CprSig, topCprSig, botCprSig, mkFunCprSig, mkPlainCprSig, seqCprSig, + cprTransformSig, cprTransformDataConWork, argCprsFromStrictSig ) where +#include "HsVersions.h" + import GHC.Prelude +import GHC.Builtin.Names ( Unique, runRWKey ) import GHC.Types.Basic -import GHC.Utils.Outputable +import GHC.Types.Demand +import GHC.Types.Termination +import GHC.Types.Unbox +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Multiplicity import GHC.Utils.Binary - --- --- * CprResult --- - --- | The constructed product result lattice. --- --- @ --- NoCPR --- | --- ConCPR ConTag --- | --- BotCPR --- @ -data CprResult = NoCPR -- ^ Top of the lattice - | ConCPR !ConTag -- ^ Returns a constructor from a data type - | BotCPR -- ^ Bottom of the lattice - deriving( Eq, Show ) - -lubCpr :: CprResult -> CprResult -> CprResult -lubCpr (ConCPR t1) (ConCPR t2) - | t1 == t2 = ConCPR t1 -lubCpr BotCPR cpr = cpr -lubCpr cpr BotCPR = cpr -lubCpr _ _ = NoCPR - -topCpr :: CprResult -topCpr = NoCPR - -botCpr :: CprResult -botCpr = BotCPR - -conCpr :: ConTag -> CprResult -conCpr = ConCPR - -trimCpr :: CprResult -> CprResult -trimCpr ConCPR{} = NoCPR -trimCpr cpr = cpr - -asConCpr :: CprResult -> Maybe ConTag -asConCpr (ConCPR t) = Just t -asConCpr NoCPR = Nothing -asConCpr BotCPR = Nothing - --- --- * CprType --- - --- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. -data CprType - = CprType - { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression - -- eats before returning the 'ct_cpr' - , ct_cpr :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to - -- 'ct_arty' arguments - } - -instance Eq CprType where - a == b = ct_cpr a == ct_cpr b - && (ct_arty a == ct_arty b || ct_cpr a == topCpr) - -topCprType :: CprType -topCprType = CprType 0 topCpr - -botCprType :: CprType -botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments - -conCprType :: ConTag -> CprType -conCprType con_tag = CprType 0 (conCpr con_tag) - -lubCprType :: CprType -> CprType -> CprType -lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2) - -- The arity of bottom CPR types can be extended arbitrarily. - | cpr1 == botCpr && n1 <= n2 = ty2 - | cpr2 == botCpr && n2 <= n1 = ty1 - -- There might be non-bottom CPR types with mismatching arities. - -- Consider test DmdAnalGADTs. We want to return top in these cases. - | n1 == n2 = CprType n1 (lubCpr cpr1 cpr2) - | otherwise = topCprType - -applyCprTy :: CprType -> CprType -applyCprTy (CprType n res) - | n > 0 = CprType (n-1) res - | res == botCpr = botCprType - | otherwise = topCprType - -abstractCprTy :: CprType -> CprType -abstractCprTy (CprType n res) - | res == topCpr = topCprType - | otherwise = CprType (n+1) res - -ensureCprTyArity :: Arity -> CprType -> CprType -ensureCprTyArity n ty@(CprType m _) - | n == m = ty - | otherwise = topCprType - -trimCprTy :: CprType -> CprType -trimCprTy (CprType arty res) = CprType arty (trimCpr res) - --- | The arity of the wrapped 'CprType' is the arity at which it is safe --- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand" -newtype CprSig = CprSig { getCprSig :: CprType } - deriving (Eq, Binary) - --- | Turns a 'CprType' computed for the particular 'Arity' into a 'CprSig' --- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in --- "GHC.Types.Demand" -mkCprSigForArity :: Arity -> CprType -> CprSig -mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Data.Maybe + +import Data.Coerce + +import GHC.Driver.Ppr +_ = pprTrace -- Tired of commenting out GHC.Driver.Ppr + +-------- +-- * Cpr + +newtype Cpr + = Cpr_ (CloShape Cpr) + deriving (Binary, Eq) + +-- | Normalises the nested CPR info according to +-- > TopSh === LamSh topCpr +-- Because CPR only cares if ultimately we see a data constructor. A 'Lam' can +-- be eta-expanded independently of whether it cancels away in the body by way +-- of an 'App'. +normCprShape :: CloShape Cpr -> CloShape Cpr +normCprShape (LamSh cpr) | cpr == topCpr = TopSh +normCprShape sh = sh + +pattern Cpr :: CloShape Cpr -> Cpr +pattern Cpr sh <- (Cpr_ sh) + where + Cpr sh = Cpr_ (normCprShape sh) +{-# COMPLETE Cpr #-} + +botCpr :: Cpr +botCpr = Cpr BotSh + +topCpr :: Cpr +topCpr = Cpr TopSh + +lubCpr :: Cpr -> Cpr -> Cpr +lubCpr (Cpr sh1) (Cpr sh2) = Cpr (lubCloShape lubCpr sh1 sh2) + +conCpr :: DataCon -> [Cpr] -> Cpr +conCpr dc cprs = Cpr (ConSh (dataConTag dc) cprs) + +pruneDeepCpr :: Int -> Cpr -> Cpr +pruneDeepCpr depth = coerce (pruneCloShape pruneDeepCpr depth) + +-- | Split for the given 'ConTag' if the 'Cpr' is of 'ConSh' or 'BotSh'. +splitConCpr :: ConTag -> Int -> Cpr -> Maybe [Cpr] +splitConCpr tag arty (Cpr sh) = splitConSh botCpr tag arty sh + +expandConFieldsCpr :: DataCon -> Cpr -> [Cpr] +expandConFieldsCpr dc c = + splitConCpr (dataConTag dc) (dataConRepArity dc) c + `orElse` replicate (dataConRepArity dc) topCpr + +splitLamCpr :: Cpr -> Maybe Cpr +splitLamCpr (Cpr BotSh) = Just botCpr +splitLamCpr (Cpr (LamSh c)) = Just c +splitLamCpr _ = Nothing + +appCpr :: Cpr -> Cpr +appCpr cpr + | Just cpr' <- splitLamCpr cpr = cpr' + | otherwise = topCpr + +appsCpr :: Arity -> Cpr -> Cpr +appsCpr n cpr = iterate appCpr cpr !! n + +lamCpr :: Cpr -> Cpr +lamCpr cpr = Cpr (LamSh cpr) + +lamsCpr :: Arity -> Cpr -> Cpr +lamsCpr n cpr = iterate lamCpr cpr !! n + +dropNonBotCpr :: Cpr -> Cpr +-- See Note [CPR for thunks] +dropNonBotCpr c + | is_bot_fun c = c -- Don't forget bot => error thunks should have CPR + | otherwise = topCpr + where + is_bot_fun (Cpr BotSh) = True + is_bot_fun (Cpr (LamSh c)) = is_bot_fun c + is_bot_fun _ = False + +-- | Trim away excess 'LamSh'. +trimLam :: Cpr -> Cpr +-- See Note [Arity trimming for CPR signatures] +trimLam (Cpr LamSh{}) = topCpr +trimLam cpr = cpr + +-- | Trims deep CPR information as soon as there is a single 'MightDiverge'. +trimToTerm :: Term -> Cpr -> Cpr +-- See Note [Trimming CPR signatures according to Term] +trimToTerm term cpr + -- No further MightDiverge in the way, stop trimming + | term == botTerm + = cpr + -- Handle bot CPR. Important for GHC.Utils.Panic.panic + | Term Terminates _ <- term + , cpr == botCpr + = botCpr + -- Handle (expansion to) ConSh + | Term Terminates (ConSh t terms) <- term + , Just cprs <- splitConCpr t (length terms) cpr + = Cpr (ConSh t (zipWith trimToTerm terms cprs)) + | Cpr (ConSh t cprs) <- cpr + , (Terminates, terms) <- splitConTerm t (length cprs) term + = Cpr (ConSh t (zipWith trimToTerm terms cprs)) + -- Handle (expansion to) LamSh + | Term Terminates (LamSh t) <- term + , Just c <- splitLamCpr cpr + = Cpr (LamSh (trimToTerm t c)) + | Cpr (LamSh c) <- cpr + , (Terminates, t) <- splitLamTerm term + = Cpr (LamSh (trimToTerm t c)) + -- Otherwise top + | otherwise + = topCpr + +seqCpr :: Cpr -> () +seqCpr = coerce (seqCloShape seqCpr) + +asConCpr :: Cpr -> Maybe (ConTag, [Cpr]) +-- This is the key function consulted by WW +asConCpr (Cpr (ConSh t cprs)) = Just (t, cprs) +asConCpr _ = Nothing + +----------- +-- * CprSig + +-- | Not just 'Cpr', because it lacks 'idArity' many 'LamSh' (see 'Sig'). +-- We also need to take some care to trim CPR results from function bodies when +-- we turn them into a 'CprSig'. See 'mkFunCprSig'. +type CprSig = Sig Cpr topCprSig :: CprSig -topCprSig = CprSig topCprType +topCprSig = Sig topCpr -mkCprSig :: Arity -> CprResult -> CprSig -mkCprSig arty cpr = CprSig (CprType arty cpr) +botCprSig :: CprSig +botCprSig = Sig botCpr seqCprSig :: CprSig -> () -seqCprSig sig = sig `seq` () - -instance Outputable CprResult where - ppr NoCPR = empty - ppr (ConCPR n) = char 'm' <> int n - ppr BotCPR = char 'b' - -instance Outputable CprType where - ppr (CprType arty res) = ppr arty <> ppr res - --- | Only print the CPR result -instance Outputable CprSig where - ppr (CprSig ty) = ppr (ct_cpr ty) - -instance Binary CprResult where - put_ bh (ConCPR n) = do { putByte bh 0; put_ bh n } - put_ bh NoCPR = putByte bh 1 - put_ bh BotCPR = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; return (ConCPR n) } - 1 -> return NoCPR - _ -> return BotCPR - -instance Binary CprType where - put_ bh (CprType arty cpr) = do - put_ bh arty - put_ bh cpr - get bh = CprType <$> get bh <*> get bh +seqCprSig = coerce seqCpr + +-- | Turns a 'Cpr' of a function into a signature that is unleashable +-- at call sites of the particular 'Arity' and minimum call 'Demand'. +-- +-- See Note [Trimming CPR signatures according to Term] +-- and Note [Improving CPR by considering strictness demand from call sites], +-- as well as Note [Arity trimming for CPR signatures], +-- all in "GHC.Core.Opt.CprAnal". +mkFunCprSig :: Arity -> Demand -> Term -> Cpr -> CprSig +mkFunCprSig arty fun_demand rhs_term rhs_cpr = + -- pprTrace "mkFunCprSig" (vcat [ppr arty, ppr fun_demand, ppr body_sd, ppr body_term, ppr body_cpr, ppr body_term', ppr final_cpr]) $ + Sig final_cpr + where + -- See Note [Improving CPR by considering strictness demand from call sites] + -- Figure out the *least sub-demand* put on the function body by all call sites. + -- Sub-demand, because we can assume at least seq demand on the body. + (_card1 :* fn_sd) = fun_demand -- how the function was called + (_card2, body_sd) = peelManyCalls arty fn_sd + -- body_sd is now the least demand put on the fun body by a single, sat call + body_term = appsTerm arty rhs_term + body_cpr = appsCpr arty rhs_cpr + (_, body_term') = forceTerm body_sd body_term -- combine with body_sd + -- See Note [Arity trimming for CPR signatures] + -- See Note [Trimming CPR signatures according to Term] + -- See Note [Trimming for mAX_CPR_SIZE] + final_cpr = trimCprSize $ trimToTerm body_term' (trimLam body_cpr) + + +-- | Takes a 'Cpr' for an expression of the given 'Arity' and turn it into a +-- signature. Unlike 'mkFunCprSig', this does no smart processing of how much +-- of the given 'Cpr' is actually available at use sites. +mkPlainCprSig :: Arity -> Cpr -> CprSig +-- Strip the arity many (and thus boring) LamSh's +mkPlainCprSig = coerce appsCpr + +-- | Compared to 'termTransformSig', this one is not higher-order! +-- ... Except for runRW#. +cprTransformSig :: Unique -> Arity -> CprSig -> [Cpr] -> Cpr +cprTransformSig id_uniq _arity _sig arg_cprs + | id_uniq == runRWKey -- `runRW :: (State# RealWorld -> o) -> o` + , [arg] <- arg_cprs -- `arg :: State# RealWorld -> o` has `L1(,1)` + = appCpr arg -- `result :: o` has `1(,1)` +cprTransformSig _id_uniq arity (Sig cpr) _arg_cprs + = lamsCpr arity cpr + +-- | Get a 'Cpr' for a 'DataCon', given 'Cpr's for its fields. +cprTransformDataConWork :: DataCon -> [Cpr] -> Cpr +-- What about DataCon *wrappers*? See Note [CPR for DataCon wrappers] +cprTransformDataConWork con args + | null (dataConExTyCoVars con) -- No existentials + , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE] + , args `lengthIs` wkr_arity + -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True + = lamsCpr wkr_arity (conCpr con args) + | otherwise + = topCpr + where + wkr_arity = dataConRepArity con + +-- | See Note [Trimming to mAX_CPR_SIZE]. +mAX_CPR_SIZE :: Arity +mAX_CPR_SIZE = 10 + +data StrictPair a b = !a :*: !b + +-- | Trims Nested CPR so that we never produce unboxed tuples of width more than +-- 'mAX_CPR_SIZE'. See Note [Trimming for mAX_CPR_SIZE]. +trimCprSize :: Cpr -> Cpr +trimCprSize cpr = case go mAX_CPR_SIZE cpr of _ :*: cpr' -> cpr' + where + go :: Int -> Cpr -> StrictPair Int Cpr + go fuel (Cpr (ConSh t fields)) + | fields `lengthAtMost` (fuel+1) -- unboxing will get rid of the box, so +1 + , fuel' :*: fields' <- go_fields (fuel+1 - length fields) fields + = fuel' :*: Cpr (ConSh t fields') + | otherwise + = fuel :*: topCpr + go fuel cpr + = fuel :*: cpr + go_fields :: Int -> [Cpr] -> StrictPair Int [Cpr] + go_fields fuel [] = fuel :*: [] + go_fields fuel (f:fs) + | fuel1 :*: f' <- go fuel f + , fuel2 :*: fs' <- go_fields fuel1 fs + = fuel2 :*: (f':fs') + +-- | Produces 'Cpr's according to how strict argument types will be unboxed. +-- Examples: +-- +-- * A head-strict demand `S` on `Int` would translate to `c1(*)` +-- * A tuple demand `S(S,L)` on `(Int, Bool)` would translate to `c1(c1(*),*)` +-- * A tuple demand `S(S,L)` on `(a , Bool)` would translate to `c1(*,*)`, +-- because the unboxing strategy would not unbox the `a`. +argCprsFromStrictSig :: UnboxingStrategy Demand -> [Type] -> StrictSig -> [Cpr] +argCprsFromStrictSig want_to_unbox arg_tys sig + = zipWith go arg_tys (fst (splitStrictSig sig)) + where + go ty dmd + | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) dmds + <- want_to_unbox ty dmd + -- No existentials; see Note [Which types are unboxed?]) + -- Otherwise we'd need to call dataConRepInstPat here and thread a UniqSupply + , null (dataConExTyCoVars dc) + , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args) + = conCpr dc (zipWith go arg_tys dmds) + | otherwise + = topCpr + +{- Note [Trimming to mAX_CPR_SIZE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not treat very big tuples as CPR-ish: + + a) For a start, we get into trouble because there aren't + "enough" unboxed tuple types (a tiresome restriction, + but hard to fix), + b) More importantly, big unboxed tuples get returned mainly + on the stack, and are often then allocated in the heap + by the caller. So doing CPR for them may in fact make + things worse, especially if the wrapper doesn't cancel away + and we move to the stack in the worker and then to the heap + in the wrapper. + +So we (nested) CPR for functions that would otherwise pass more than than +'mAX_CPR_SIZE' fields. +That effect is exacerbated for the unregisterised backend, where we +don't have any hardware registers to return the fields in. Returning +everything on the stack results in much churn and increases compiler +allocation by 15% for T15164 in a validate build. +-} + +-- | Formats `lamCpr (conCpr 3 [conCpr 5 [topCpr], conCpr 2 [topCpr, botCpr])` +-- as `L3(5,2(,b))`. +instance Outputable Cpr where + ppr (Cpr l) = pprCloShape (char 'b') (any (/= topCpr)) l diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index c2e4770da6..cbd93680a7 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -15,9 +15,9 @@ -- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal". module GHC.Types.Demand ( -- * Demands - Card(..), Demand(..), SubDemand(Prod), mkProd, viewProd, + Card(..), Demand(..), SubDemand(Prod, Call), mkProd, viewProd, viewCall, -- ** Algebra - absDmd, topDmd, botDmd, seqDmd, topSubDmd, + absDmd, topDmd, botDmd, seqDmd, topSubDmd, seqSubDmd, -- *** Least upper bound lubCard, lubDmd, lubSubDmd, -- *** Plus @@ -559,17 +559,20 @@ mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity -- | Peels one call level from the sub-demand, and also returns how many -- times we entered the lambda body. peelCallDmd :: SubDemand -> (Card, SubDemand) -peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd) +peelCallDmd = peelManyCalls 1 -- Peels multiple nestings of 'Call' sub-demands and also returns -- whether it was unsaturated in the form of a 'Card'inality, denoting -- how many times the lambda body was entered. -- See Note [Demands from unsaturated function calls]. -peelManyCalls :: Int -> SubDemand -> Card -peelManyCalls 0 _ = C_11 +peelManyCalls :: Int -> SubDemand -> (Card, SubDemand) +peelManyCalls 0 sd = (C_11, sd) -- See Note [Call demands are relative] -peelManyCalls n (viewCall -> Just (m, sd)) = m `multCard` peelManyCalls (n-1) sd -peelManyCalls _ _ = C_0N +peelManyCalls n (viewCall -> Just (m, sd)) + | (n, body_sd) <- peelManyCalls (n-1) sd + , !n' <- m `multCard` n + = (n', body_sd) +peelManyCalls _ _ = (topCard, topSubDmd) -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap mkWorkerDemand :: Int -> Demand @@ -618,7 +621,7 @@ argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative] -- There are at least n nested C1(..) calls. -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap saturatedByOneShots :: Int -> Demand -> Bool -saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd) +saturatedByOneShots n (_ :* sd) = isUsedOnce $ fst $ peelManyCalls n sd {- Note [Strict demands] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1502,7 +1505,7 @@ type DmdTransformer = SubDemand -> DmdType -- return how the function evaluates its free variables and arguments. dmdTransformSig :: StrictSig -> DmdTransformer dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) sd - = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty + = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty -- see Note [Demands from unsaturated function calls] -- and Note [What are demand signatures?] diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index b0c83ce8b2..feb67ad7e7 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -58,6 +58,7 @@ module GHC.Types.Id ( zapIdUsedOnceInfo, zapIdTailCallInfo, zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, transferPolyIdInfo, scaleIdBy, scaleVarBy, + setDivergingIdInfo, -- ** Predicates on Ids isImplicitId, isDeadBinder, @@ -112,10 +113,12 @@ module GHC.Types.Id ( setIdDemandInfo, setIdStrictness, + setIdTermInfo, setIdCprInfo, idDemandInfo, idStrictness, + idTermInfo, idCprInfo, ) where @@ -145,6 +148,7 @@ import GHC.Builtin.Types.Prim import GHC.Core.DataCon import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Types.Name import GHC.Unit.Module import GHC.Core.Class @@ -179,8 +183,11 @@ infixl 1 `setIdUnfolding`, `setIdDemandInfo`, `setIdStrictness`, + `setIdTermInfo`, `setIdCprInfo`, + `setDivergingIdInfo`, + `asJoinId`, `asJoinId_maybe` @@ -260,6 +267,9 @@ maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info maybeModifyIdInfo Nothing id = id +setDivergingIdInfo :: Id -> [Demand] -> Id +setDivergingIdInfo id arg_dmds = modifyIdInfo (`setDivergingInfo` arg_dmds) id + {- ************************************************************************ * * @@ -683,6 +693,12 @@ idStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictSig -> Id setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id +idTermInfo :: Id -> TermSig +idTermInfo id = termInfo (idInfo id) + +setIdTermInfo :: Id -> TermSig -> Id +setIdTermInfo id sig = modifyIdInfo (\info -> setTermInfo info sig) id + idCprInfo :: Id -> CprSig idCprInfo id = cprInfo (idInfo id) @@ -1001,12 +1017,14 @@ transferPolyIdInfo old_id abstract_wrt new_id old_strictness = strictnessInfo old_info new_strictness = prependArgsStrictSig arity_increase old_strictness + old_term = termInfo old_info old_cpr = cprInfo old_info transfer new_info = new_info `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag `setOccInfo` new_occ_info `setStrictnessInfo` new_strictness + `setTermInfo` old_term `setCprInfo` old_cpr isNeverLevPolyId :: Id -> Bool diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 0ece12cefa..1c85500e99 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -23,6 +23,7 @@ module GHC.Types.Id.Info ( -- * The IdInfo type IdInfo, -- Abstract vanillaIdInfo, noCafIdInfo, + setDivergingInfo, -- ** The OneShotInfo type OneShotInfo(..), @@ -43,6 +44,7 @@ module GHC.Types.Id.Info ( -- ** Demand and strictness Info strictnessInfo, setStrictnessInfo, + termInfo, setTermInfo, cprInfo, setCprInfo, demandInfo, setDemandInfo, pprStrictness, @@ -107,6 +109,7 @@ import GHC.Types.ForeignCall import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Utils.Misc import GHC.Utils.Outputable @@ -126,10 +129,12 @@ infixl 1 `setRuleInfo`, `setOccInfo`, `setCafInfo`, `setStrictnessInfo`, + `setTermInfo`, `setCprInfo`, `setDemandInfo`, `setNeverLevPoly`, - `setLevityInfoWithType` + `setLevityInfoWithType`, + `setDivergingInfo` {- ************************************************************************ @@ -266,6 +271,9 @@ data IdInfo strictnessInfo :: StrictSig, -- ^ A strictness signature. Digests how a function uses its arguments -- if applied to at least 'arityInfo' arguments. + termInfo :: TermSig, + -- ^ Deep rapid termination information at different levels. + -- A nested and second-order 'GHC.Core.Utils.exprOkForSpeculation'. cprInfo :: CprSig, -- ^ Information on whether the function will ultimately return a -- freshly allocated constructor. @@ -412,8 +420,11 @@ setDemandInfo info dd = dd `seq` info { demandInfo = dd } setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } +setTermInfo :: IdInfo -> TermSig -> IdInfo +setTermInfo info term = seqTermSig term `seq` info { termInfo = term } + setCprInfo :: IdInfo -> CprSig -> IdInfo -setCprInfo info cpr = cpr `seq` info { cprInfo = cpr } +setCprInfo info cpr = seqCprSig cpr `seq` info { cprInfo = cpr } -- | Basic 'IdInfo' that carries no useful information whatsoever vanillaIdInfo :: IdInfo @@ -425,6 +436,7 @@ vanillaIdInfo occInfo = noOccInfo, demandInfo = topDmd, strictnessInfo = nopSig, + termInfo = topTermSig, cprInfo = topCprSig, bitfield = bitfieldSetCafInfo vanillaCafInfo $ bitfieldSetArityInfo unknownArity $ @@ -692,6 +704,17 @@ zapTailCallInfo info zapCallArityInfo :: IdInfo -> IdInfo zapCallArityInfo info = setCallArityInfo info 0 +-- | Set the 'IdInfo' for a binding forces its arguments according to the given +-- demands and then diverges.. +setDivergingInfo :: IdInfo -> [Demand] -> IdInfo +setDivergingInfo info arg_dmds = + info `setStrictnessInfo` mkClosedStrictSig arg_dmds botDiv + `setTermInfo` divergeTermSig + `setCprInfo` botCprSig + `setArityInfo` arity + where + !arity = length arg_dmds + {- ************************************************************************ * * diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 665a32a538..f8f97755ff 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -69,6 +69,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.Termination import GHC.Types.TyThing import GHC.Core import GHC.Types.Unique @@ -483,7 +484,6 @@ mkDictSelId name clas base_info = noCafIdInfo `setArityInfo` 1 `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig `setLevityInfoWithType` sel_ty info | new_tycon @@ -580,7 +580,6 @@ mkDataConWorkId wkr_name data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo `setArityInfo` wkr_arity - `setCprInfo` mkCprSig wkr_arity (dataConCPR data_con) `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 @@ -608,31 +607,6 @@ mkDataConWorkId wkr_name data_con mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) -dataConCPR :: DataCon -> CprResult -dataConCPR con - | isDataTyCon tycon -- Real data types only; that is, - -- not unboxed tuples or newtypes - , null (dataConExTyCoVars con) -- No existentials - , wkr_arity > 0 - , wkr_arity <= mAX_CPR_SIZE - = conCpr (dataConTag con) - | otherwise - = topCpr - where - tycon = dataConTyCon con - wkr_arity = dataConRepArity con - - mAX_CPR_SIZE :: Arity - mAX_CPR_SIZE = 10 - -- We do not treat very big tuples as CPR-ish: - -- a) for a start we get into trouble because there aren't - -- "enough" unboxed tuple types (a tiresome restriction, - -- but hard to fix), - -- b) more importantly, big unboxed tuples get returned mainly - -- on the stack, and are often then allocated in the heap - -- by the caller. So doing CPR for them may in fact make - -- things worse. - {- ------------------------------------------------- -- Data constructor representation @@ -709,7 +683,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con `setInlinePragInfo` wrap_prag `setUnfoldingInfo` wrap_unf `setStrictnessInfo` wrap_sig - `setCprInfo` mkCprSig wrap_arity (dataConCPR data_con) + -- `setCprInfo` topCprSig -- See Note [CPR for DataCon wrappers] -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane @@ -717,10 +691,11 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con wrap_sig = mkClosedStrictSig wrap_arg_dmds topDiv + -- Don't forget the dictionary arguments when building the + -- strictness signature (#14290). Notably, this does not include + -- eq_spec, because they are generated inside the wrapper. wrap_arg_dmds = replicate (length theta) topDmd ++ map mk_dmd arg_ibangs - -- Don't forget the dictionary arguments when building - -- the strictness signature (#14290). mk_dmd str | isBanged str = evalDmd | otherwise = topDmd @@ -735,8 +710,6 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con -- particular, the wrapper constructor is not inlined inside -- an INLINE rhs or when it is not applied to any arguments. -- See Note [Inline partially-applied constructor wrappers] - -- Passing Nothing here allows the wrapper to inline when - -- unsaturated. wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding defaultSimpleOpts wrap_rhs -- See Note [Compulsory newtype unfolding] | otherwise = mkInlineUnfolding defaultSimpleOpts wrap_rhs @@ -1318,16 +1291,25 @@ mkPrimOpId prim_op (AnId id) UserSyntax id = mkGlobalId (PrimOpId prim_op) name ty info - -- PrimOps don't ever construct a product, but we want to preserve bottoms - cpr - | isDeadEndDiv (snd (splitStrictSig strict_sig)) = botCpr - | otherwise = topCpr + -- PrimOps never construct a product, but we want to assume that + -- 1. Ok-for-spec ones (i.e. `+#`) terminate. + -- 2. Those which have dead end Divergence (i.e. `raise#`) have + -- `divergeTerm`. If we manage to evaluate them to WHNF (which we + -- never do), they have infinitely deep CPR and termination: This is + -- so that we give an `if ... then error "blah" else (1, 2)` the + -- nested CPR property. + -- In all other cases we simply assume `topCpr`. + (term, cpr) | primOpOkForSpeculation prim_op = (whnfTermSig, topCprSig) + | isDeadEndSig strict_sig = (divergeTermSig, botCprSig) + | otherwise = (topTermSig, topCprSig) + info = noCafIdInfo `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) `setArityInfo` arity `setStrictnessInfo` strict_sig - `setCprInfo` mkCprSig arity cpr + `setTermInfo` term + `setCprInfo` cpr `setInlinePragInfo` neverInlinePragma `setLevityInfoWithType` res_ty -- We give PrimOps a NOINLINE pragma so that we don't @@ -1360,7 +1342,6 @@ mkFCallId dflags uniq fcall ty info = noCafIdInfo `setArityInfo` arity `setStrictnessInfo` strict_sig - `setCprInfo` topCprSig `setLevityInfoWithType` ty (bndrs, _) = tcSplitPiTys ty diff --git a/compiler/GHC/Types/Termination.hs b/compiler/GHC/Types/Termination.hs new file mode 100644 index 0000000000..d2294fdcac --- /dev/null +++ b/compiler/GHC/Types/Termination.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ApplicativeDo #-} + +-- | Types for the lattice that the termination analyis in +-- "GHC.Core.Opt.CprAnal" operates on. The resulting information is stored in +-- 'GHC.Types.Id.idTermInfo'. +module GHC.Types.Termination ( + -- * Closure shape + CloShape (..), lubCloShape, splitConSh, splitLamSh, pruneCloShape, + seqCloShape, pprCloShape, + -- * TermFlag + TermFlag (Terminates), + -- * Termination lattice + Term(Term), botTerm, topTerm, lubTerm, bothTerm, whnfTerm, divergeTerm, + appTerm, appsTerm, lamTerm, forceTerm, whnfTerminatesRapidly, pruneDeepTerm, + splitConTerm, splitLamTerm, expandConFieldsTerm, trimTermToArity, + -- * Termination signatures + Sig (..), TermSig, topTermSig, whnfTermSig, divergeTermSig, mkTermSig, + termTransformDataConWork, termTransformSig, argTermsFromStrictSig, + seqTermSig + ) where + +#include "HsVersions.h" + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Types.Demand +import GHC.Core.DataCon +import GHC.Utils.Binary +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Maybe + +import Data.Coerce +import qualified Data.Semigroup as Semigroup +import Data.Functor.Identity +import Control.Applicative (Const (..)) +import Control.Monad.Trans.Writer.CPS +import Control.Monad (zipWithM) + +import GHC.Driver.Ppr +_ = pprTrace -- Tired of commenting out GHC.Driver.Ppr + +------------- +-- * CloShape + +-- | Abstracts the runtime shape of a heap closure. +data CloShape r + = BotSh + | LamSh !r + | ConSh !ConTag [r] + | TopSh + deriving Eq + +lubCloShape :: (r -> r -> r) -> CloShape r -> CloShape r -> CloShape r +lubCloShape _ BotSh sh = sh +lubCloShape _ sh BotSh = sh +lubCloShape lub_r (LamSh r1) (LamSh r2) = LamSh (lub_r r1 r2) +lubCloShape lub_r (ConSh t1 args1) (ConSh t2 args2) + | t1 == t2, args1 `equalLength` args2 + = (ConSh t1 (zipWith lub_r args1 args2)) +lubCloShape _ _ _ = TopSh + +-- | Prune the nesting depth of data structures +pruneCloShape :: (Int -> r -> r) -> Int -> CloShape r -> CloShape r +pruneCloShape _ 0 _ = TopSh +pruneCloShape prune_r depth (ConSh t args) = ConSh t (map (prune_r (depth - 1)) args) +pruneCloShape prune_r depth (LamSh r) = LamSh (prune_r depth r) -- only apply depth to data structures! +pruneCloShape _ _ sh = sh + +-- | Return fields for a 'ConSh' with the given 'ConTag' and arity, the +-- approriate number of 'bot's for a 'BotSh', or 'Nothing'. +splitConSh :: r -> ConTag -> Arity -> CloShape r -> Maybe [r] +splitConSh bot _ arty BotSh = Just $! replicate arty bot +splitConSh _ tag arty (ConSh t fields) + | tag == t + , length fields == arty -- See Note [CPR types and unsafeCoerce] + = Just fields +splitConSh _ _ _ _ = Nothing + +splitLamSh :: r -> CloShape r -> Maybe r +splitLamSh bot BotSh = Just bot +splitLamSh _ (LamSh r) = Just r +splitLamSh _ _ = Nothing + +seqCloShape :: (r -> ()) -> CloShape r -> () +seqCloShape seq_r (ConSh _ args) = foldr (seq . seq_r) () args +seqCloShape seq_r (LamSh r) = seq_r r +seqCloShape _ _ = () + +{- Note [CPR types and unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unsafe coercions may lead to looking into a CPR type analysed for a different +type than the type of the expression a case scrutinises. Example (like T16893): + + data T = T Int + data U = U Int Int + ... (case unsafeCoerce (U 1 2 :: U) of + T i -> ...) ... + +Although we can only derive bogus in these situations, we shouldn't try to +unpack the 2 field CPR type from the scrutinee into a 1 field type matching +the pattern. That led to a deliberate panic when calling @zipEqual@ in +'CprAnal.cprAnalAlt'. Nothing bad was happening, just a precautionary +panic on T16893. +-} + +---------------- +-- * Termination + +data TermFlag + = Terminates + | MightDiverge + deriving Eq + +lubTermFlag :: TermFlag -> TermFlag -> TermFlag +lubTermFlag Terminates Terminates = Terminates +lubTermFlag _ MightDiverge = MightDiverge +lubTermFlag MightDiverge _ = MightDiverge + +data Term + = Term_ !TermFlag !(CloShape Term) + -- ^ Don't use 'Term_', use 'Term' instead! Otherwise the derived Eq instance + -- is broken. + deriving Eq + +-- | Normalises the nested termination info according to +-- > TopSh === ConSh t [topTerm..] +-- > BotSh === ConSh t [botTerm..] +-- > TopSh === LamSh topTerm +-- > BotSh === LamSh botTerm +-- (Note that this identity doesn't hold for CPR!): +normTermShape :: CloShape Term -> CloShape Term +normTermShape (ConSh _ fields) + | all (== topTerm) fields = TopSh + | all (== botTerm) fields = BotSh +normTermShape (LamSh t) + | t == topTerm = TopSh + | t == botTerm = BotSh +normTermShape sh = sh + +pattern Term :: TermFlag -> CloShape Term -> Term +pattern Term tf s <- (Term_ tf s) + where + -- 'normTermShape' is the main point of this synonym. The first 4 case alts + -- are only for interning purposes. + Term tf (normTermShape -> sh) = case (tf, sh) of + (Terminates, BotSh) -> botTerm + (Terminates, TopSh) -> whnfTerm + (MightDiverge, BotSh) -> divergeTerm + (MightDiverge, TopSh) -> topTerm + (tf, sh ) -> Term_ tf sh +{-# COMPLETE Term #-} + +topTerm :: Term +topTerm = Term_ MightDiverge TopSh + +botTerm :: Term +botTerm = Term_ Terminates BotSh + +whnfTerm :: Term +whnfTerm = Term_ Terminates TopSh + +-- | Used as the 'Term' of 'undefined'/'error'/other sources of divergence. +-- +-- We assume that evaluation to WHNF surely diverges (so 'MightDiverge'), but +-- are optimistic about nested termination information. I.e., we +-- assume that returned tuple components terminate rapidly. +divergeTerm :: Term +divergeTerm = Term_ MightDiverge BotSh + +conTerm :: DataCon -> [Term] -> Term +conTerm dc terms = Term Terminates (ConSh (dataConTag dc) terms') + where + -- See Note [No unboxed tuple for single, unlifted transit var] + terms' = zipWithEqual "conTerm" add terms strs + strs = dataConRepStrictness dc + add t str | isMarkedStrict str = getForcedTerm $ forceTermM topSubDmd t + | otherwise = t + +lubTerm :: Term -> Term -> Term +lubTerm (Term tf1 sh1) (Term tf2 sh2) = + Term (lubTermFlag tf1 tf2) (lubCloShape lubTerm sh1 sh2) + +pruneDeepTerm :: Int -> Term -> Term +pruneDeepTerm depth (Term tf sh) = + Term tf (pruneCloShape pruneDeepTerm depth sh) + +-- | Return fields of a 'ConSh' of the given 'ConTag' and arity, and make +-- up approprate field 'Term's for the other cases ('BotSh' -> 'botTerm', +-- all others 'topTerm'). Also return outer 'TermFlag'. +splitConTerm :: ConTag -> Arity -> Term -> (TermFlag, [Term]) +splitConTerm tag arty (Term tf sh) = + (,) tf $! splitConSh botTerm tag arty sh `orElse` replicate arty topTerm + +expandConFieldsTerm :: DataCon -> Term -> [Term] +expandConFieldsTerm dc t = snd $ splitConTerm (dataConTag dc) (dataConRepArity dc) t + +splitLamTerm :: Term -> (TermFlag, Term) +splitLamTerm (Term tf sh) = + (,) tf $! splitLamSh botTerm sh `orElse` topTerm + +-- | Applies a 'LamSh', accounting the outer 'TermFlag' to the inner one. +-- >>> appTerm (Term MightDiverge (LamSh (Term Terminates BotSh))) +-- Term MightDiverge BotSh +appTerm :: Term -> Term +appTerm (splitLamTerm -> (tf, term)) = term `bothTerm` tf + +-- | `appsTerm n` is n iterations of 'appTerm'. +appsTerm :: Arity -> Term -> Term +appsTerm arty term = iterate appTerm term !! arty + +lamTerm :: Term -> Term +lamTerm t = Term Terminates (LamSh t) + +-- | `lamsTerm n` is n iterations of 'lamTerm'. +lamsTerm :: Arity -> Term -> Term +lamsTerm arty term = iterate lamTerm term !! arty + +-- | 'lubTerm's the given outer 'TermFlag' onto the 'Term'. +bothTerm :: Term -> TermFlag -> Term +-- If tf = Terminates, it's just 'id'. +-- If tf = MightDiverge, it will only set the WHNF layer to MightDiverge, +-- leaving nested termination info (e.g. on product components) intact. +bothTerm term Terminates = term +bothTerm (Term _ sh) MightDiverge = Term MightDiverge sh + +-- | Makes sure there are exactly arity many successive, terminating 'LamSh's, +-- pushing intermittent 'MightDiverge's inwards. +-- It's like eta-expansion on 'Term' in that it pushes work (MD) under lambdas. +trimTermToArity :: Arity -> Term -> Term +trimTermToArity n (Term tf sh) = go n tf sh + where + go 0 tf (LamSh _ ) = Term tf TopSh + go 0 tf sh = Term tf sh + go n _ TopSh = lam_go n MightDiverge TopSh + go n tf ConSh{} = go n tf TopSh + go n tf (LamSh (Term tf' sh)) = lam_go n (lubTermFlag tf tf') sh + go n tf BotSh = lam_go n tf BotSh + lam_go n tf sh = Term Terminates (LamSh (go (n-1) tf sh)) + +seqTerm :: Term -> () +seqTerm (Term _ l) = seqCloShape seqTerm l + +--------------------------------- +-- * Forcing 'Term' with 'Demand' +-- +-- See Note [Rapid termination for strict binders] + +termFlag2Any :: TermFlag -> Semigroup.Any +termFlag2Any MightDiverge = Semigroup.Any True +termFlag2Any Terminates = Semigroup.Any False + +any2TermFlag :: Semigroup.Any -> TermFlag +any2TermFlag (Semigroup.Any True) = MightDiverge +any2TermFlag (Semigroup.Any False) = Terminates + +class Applicative f => ApplicativeTermination f where + noteTermFlag :: TermFlag -> f () + +-- | For extracting a 'TermFlag' from 'forceTermM' +newtype GetTermFlagM a = GetTermFlagM (Const Semigroup.Any a) + deriving (Functor, Applicative) +-- | For extracting the forced 'Term' from 'forceTermM' +newtype GetTermM a = GetTermM (Identity a) + deriving (Functor, Applicative) +-- | For extracting both the 'TermFlag' and the forced 'Term' from 'forceTermM' +newtype TerminationM a = TerminationM (Writer Semigroup.Any a) + deriving (Functor, Applicative) + +instance ApplicativeTermination GetTermFlagM where + noteTermFlag = GetTermFlagM . Const . termFlag2Any +instance ApplicativeTermination GetTermM where + noteTermFlag _ = pure () +instance ApplicativeTermination TerminationM where + noteTermFlag = TerminationM . tell . termFlag2Any + +getTermFlag :: GetTermFlagM a -> TermFlag +getTermFlag (GetTermFlagM f) = any2TermFlag $ getConst f + +getForcedTerm :: GetTermM a -> a +getForcedTerm (GetTermM f) = runIdentity f + +getTermFlagAndForcedTerm :: TerminationM a -> (TermFlag, a) +getTermFlagAndForcedTerm (TerminationM act) = case runWriter act of + (!a, !m) -> (any2TermFlag m, a) + +-- | Lifts a 'TerminationM' action from 'SubDemand's to 'Demand's by returning +-- the original argument if the 'Demand' is not strict. +-- Follows the rule "Don't force if lazy!". +idIfLazy :: Applicative f => (SubDemand -> cpr -> f cpr) -> Demand -> cpr -> f cpr +idIfLazy k (n :* sd) cpr + | isStrict n = k sd cpr + | otherwise = pure cpr + +-- | Forces possibly deep 'Term' info according to incoming 'SubDemand'. +-- If there's any possibility that this 'MightDiverge', return that. +-- See Note [Rapid termination for strict binders] +forceTerm :: SubDemand -> Term -> (TermFlag, Term) +forceTerm sd term = getTermFlagAndForcedTerm (forceTermM sd term) + +forceTermM :: ApplicativeTermination f => SubDemand -> Term -> f Term +forceTermM sd (Term tf sh) = do + -- 1. discharge head strictness by noting the term flag + noteTermFlag tf + -- 2. discharge *nested* strictness on available nested info + sh' <- case (sh, sd) of + (BotSh, _) -> pure BotSh + (LamSh t, viewCall -> Just (n, sd)) + | isStrict n + -> LamSh <$> forceTermM sd t + (TopSh, Call n sd) + | isStrict n + -> LamSh <$> forceTermM sd topTerm + (ConSh t fields, Prod ds) + | t == fIRST_TAG + , length ds <= mAX_TERM_CON_SIZE + -> ConSh fIRST_TAG <$> forceTermsM ds fields + (TopSh, Prod ds) + | length ds <= mAX_TERM_CON_SIZE + -> ConSh fIRST_TAG <$> traverse (flip (idIfLazy forceTermM) topTerm) ds + _ -> pure sh + pure (Term Terminates sh') + +forceTermsM :: ApplicativeTermination f => [Demand] -> [Term] -> f [Term] +forceTermsM = zipWithM (idIfLazy forceTermM) +{-# INLINE forceTermsM #-} + +whnfTerminatesRapidly :: Term -> Bool +whnfTerminatesRapidly term = + getTermFlag (forceTermM topSubDmd term) == Terminates + +-- | A signature of `l`, which is attached to 'Id's and unleashed at use sites. +-- +-- Why is this necessary? Answer: The wrapped `l` will lack 'idArity' many +-- 'LamSh's, simply for redundancy and efficiency reasons (repeated +-- wrapping/unwrapping, but also serialisation/deserialisation to +-- interface files). +-- +-- For a related distinction, see Note [Understanding DmdType and StrictSig] in +-- "GHC.Types.Demand". +newtype Sig l = Sig { getSig :: l } + deriving (Eq, Outputable, Binary) + +-- | Signatures need to be unleashed through 'termTransformSig' to account for +-- strict arguments and 'idArity' missing 'LamSh's, hence this is not just +-- 'Term'. +-- See Note [Rapid termination for strict binders] in "GHC.Core.Opt.CprAnal". +type TermSig = Sig Term + +topTermSig :: TermSig +topTermSig = Sig topTerm + +whnfTermSig :: TermSig +whnfTermSig = Sig whnfTerm + +divergeTermSig :: TermSig +divergeTermSig = Sig divergeTerm + +seqTermSig :: TermSig -> () +seqTermSig = coerce seqTerm + +-- | Turns a 'Term' of a function RHS into a signature that is unleashable +-- at call sites of the particular 'Arity'. +mkTermSig :: Arity -> Term -> TermSig +-- Strip the arity many (and thus boring) LamSh's +mkTermSig arity rhs_term = Sig $ appsTerm arity rhs_term + +termTransformSig :: Arity -> StrictSig -> TermSig -> [Term] -> Term +-- See Note [Rapid termination for strict binders] in CprAnal +termTransformSig arity str_sig (Sig body_term) arg_terms + | dmds <- argDmdsFromStrictSig str_sig + , tf <- getTermFlag $ forceTermsM dmds (arg_terms ++ repeat topTerm) + , body_term' <- body_term `bothTerm` tf + = -- pprTrace "termTransformSig" (ppr str_sig <+> ppr sig_term <+> ppr arg_terms <+> ppr tf <+> ppr sig_term') $ + lamsTerm arity body_term' + +-- | We have to be sure that 'termTransformSig' and 'argTermsFromStrictSig' +-- agree in how they compute the 'Demand's for which the 'TermSig' is computed. +-- This function encodes the common (trivial) logic, making sure it doesn't go +-- out of sync in the future. +argDmdsFromStrictSig :: StrictSig -> [Demand] +-- NB: Doesn't need to account for strict fields, as in +-- Note [Add demands for strict constructors]. +argDmdsFromStrictSig = fst . splitStrictSig + +-- | Produces 'Term's that match the given strictness signature. Examples: +-- +-- * A head-strict demand `S` would translate to `#` +-- * A tuple demand `S(S,L)` would translate to `#1(#,*)` +-- * A call demand `C(S)` would translate to `#L(#)` +argTermsFromStrictSig :: StrictSig -> [Term] +argTermsFromStrictSig sig = + getForcedTerm $ forceTermsM (argDmdsFromStrictSig sig) (repeat topTerm) + +-- | Get a 'Term' for a 'DataCon', given 'Term's for its fields. +termTransformDataConWork :: DataCon -> [Term] -> Term +-- What about DataCon *wrappers*? See Note [CPR for DataCon wrappers] +-- NB: Evaluation of the worker always terminates, because all fields are lazy. +-- Evaluation of the arguments is done by the DataCon wrapper. +termTransformDataConWork con args + | wkr_arity <= mAX_TERM_CON_SIZE + = -- pprTrace "termTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) $ + lamsTerm wkr_arity (conTerm con args') + | otherwise -- We do not record termination info for components of big tuples + = topTerm -- because it leads to bloated interface files, and because most + where -- of the fields generally diverge anyway. + wkr_arity = dataConRepArity con + args' = take wkr_arity $ args ++ repeat topTerm + +mAX_TERM_CON_SIZE :: Arity +mAX_TERM_CON_SIZE = 10 + +--------------- +-- * Outputable + +pprCloShape :: Outputable r => SDoc -> ([r] -> Bool) -> CloShape r -> SDoc +pprCloShape bot should_print_fields sh = case sh of + BotSh -> bot + TopSh -> empty + LamSh sh -> char 'L' <> ppr sh + ConSh t fs + | should_print_fields fs -> int t <> parens (pprWithCommas ppr fs) + | otherwise -> int t + +instance Outputable TermFlag where + ppr MightDiverge = char '*' + ppr Terminates = char '#' + +instance Outputable Term where + ppr (Term tf l) = ppr tf <> pprCloShape (text "(#..)") (const True) l + +----------- +-- * Binary + +instance Binary r => Binary (CloShape r) where + put_ bh BotSh = putByte bh 0 + put_ bh (LamSh r) = putByte bh 1 *> put_ bh r + put_ bh (ConSh t fs) = putByte bh 2 *> put_ bh t *> put_ bh fs + put_ bh TopSh = putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> return BotSh + 1 -> LamSh <$> get bh + 2 -> ConSh <$> get bh <*> get bh + 3 -> return TopSh + _ -> pprPanic "Binary CloShape: Invalid tag" (int (fromIntegral h)) + +instance Binary TermFlag where + put_ bh Terminates = put_ bh True + put_ bh MightDiverge = put_ bh False + get bh = do + b <- get bh + if b + then pure Terminates + else pure MightDiverge + +instance Binary Term where + put_ bh (Term tf l) = put_ bh tf >> put_ bh l + get bh = Term <$> get bh <*> get bh diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs index 0a10fde9b3..da5c0c61c4 100644 --- a/compiler/GHC/Types/Unique/Supply.hs +++ b/compiler/GHC/Types/Unique/Supply.hs @@ -45,7 +45,7 @@ import GHC.Utils.Monad import Control.Monad import Data.Bits import Data.Char -import GHC.Exts( Ptr(..), noDuplicate# ) +import GHC.Exts( Ptr(..), noDuplicate#, lazy ) #if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# ) #if defined(DEBUG) @@ -227,9 +227,13 @@ mkSplitUniqSupply c -- deferred IO computations case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) -> case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) -> - (# s4, MkSplitUniqSupply (mask .|. u) x y #) + (# s4, dont_cpr $ MkSplitUniqSupply (mask .|. u) x y #) }}}} + -- Do not CPR the occ of MkSplitUniqsupply, it won't cancel through + -- 'unsafeDupableInterleaveIO' anyway. + dont_cpr = GHC.Exts.lazy + #if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) foreign import ccall unsafe "genSym" genSym :: IO Int #else diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a83c5ebe16..a493f15ce4 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -655,6 +655,7 @@ Library GHC.Types.SourceText GHC.Types.SrcLoc GHC.Types.Target + GHC.Types.Termination GHC.Types.TypeEnv GHC.Types.TyThing GHC.Types.Unbox diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst index ee5b1de95e..92fd62cde7 100644 --- a/docs/users_guide/using-optimisation.rst +++ b/docs/users_guide/using-optimisation.rst @@ -306,6 +306,41 @@ by saying ``-fno-wombat``. Turn on CPR analysis in the demand analyser. +.. ghc-flag:: -fcase-binder-cpr-depth + :shortdesc: Maximum depth at which case binders have the CPR property. + :type: dynamic + :category: + + :default: 1 + + Normally, case binders get the CPR property if their scrutinee had it. + But depending on whether the case binder occurs on a cold path, it may make sense + to give it the CPR property unconditionally. + + This flag controls how deep inside a constructor application we still + consider CPR binders to have th CPR property. The default is 1, so the + following function will have the CPR property: :: + + f :: Bool -> Int -> Int + f False _ = 1 + f _ x@2 = x + f _ _ = 3 + + Note that ``x`` did not occur nested inside a constructor, so depth 1. + + On the other hand, the following function will *not* have the Nested CPR + property: :: + + g :: Bool -> Int -> (Int, Int) + g False _ = (1, 1) + g _ x@2 = (x, x) + g _ _ = (3, 3) + + Because ``x`` occurs nested inside a pair, so at depth 2. + + Depth 0 will never give any CPR binder the CPR property, unless the + scrutinee had it to begin with. + .. ghc-flag:: -fcse :shortdesc: Enable common sub-expression elimination. Implied by :ghc-flag:`-O`. :type: dynamic diff --git a/testsuite/tests/arityanal/should_compile/Arity01.stderr b/testsuite/tests/arityanal/should_compile/Arity01.stderr index bdee9d75db..6c1a6ce9fe 100644 --- a/testsuite/tests/arityanal/should_compile/Arity01.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity01.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 61, types: 45, coercions: 0, joins: 0/0} +Result size of Tidy Core = {terms: 61, types: 41, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} F1.f2 :: Integer @@ -13,9 +13,9 @@ F1.f1_h1 [Occ=LoopBreaker] :: Integer -> Integer -> Integer -> Integer [GblId, Arity=3, Str=<MU><MU><MU>, Unf=OtherCon []] F1.f1_h1 = \ (n :: Integer) (x :: Integer) (eta :: Integer) -> - case GHC.Num.Integer.integerCompare x n of { + case GHC.Num.Integer.integerLt# x n of { __DEFAULT -> eta; - LT -> F1.f1_h1 n (GHC.Num.Integer.integerAdd x F1.f2) (GHC.Num.Integer.integerAdd x eta) + 1# -> F1.f1_h1 n (GHC.Num.Integer.integerAdd x F1.f2) (GHC.Num.Integer.integerAdd x eta) } end Rec } @@ -43,11 +43,12 @@ F1.s1 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] F1.s1 = 3 --- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} +-- RHS size: {terms: 8, types: 7, coercions: 0, joins: 0/0} s :: forall {t1} {t2}. Num t1 => (t1 -> t2) -> t2 [GblId, Arity=2, Str=<1P(A,A,A,A,A,A,1C1(U))><SCS(U)>, + Term=#L#L#, 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= \ (@t) (@t1) ($dNum [Occ=Once1] :: Num t) (f [Occ=Once1!] :: t -> t1) -> f (fromInteger @t $dNum F1.s1)}] s = \ (@t) (@t1) ($dNum :: Num t) (f :: t -> t1) -> f (fromInteger @t $dNum F1.s1) diff --git a/testsuite/tests/arityanal/should_compile/Arity02.stderr b/testsuite/tests/arityanal/should_compile/Arity02.stderr index 47754d5944..cd10672cc2 100644 --- a/testsuite/tests/arityanal/should_compile/Arity02.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity02.stderr @@ -1,17 +1,18 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 35, types: 27, coercions: 0, joins: 0/0} +Result size of Tidy Core = {terms: 35, types: 23, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} F2.f1 :: Integer [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}] F2.f1 = 0 --- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0} +-- RHS size: {terms: 7, types: 6, coercions: 0, joins: 0/0} f2f :: forall {t1} {t2}. (t1 -> Integer -> t2) -> t1 -> t2 [GblId, Arity=2, Str=<SCS(CS(U))><U>, + Term=#L#L#, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) Tmpl= \ (@t) (@t1) (h [Occ=Once1!] :: t -> Integer -> t1) (x [Occ=Once1] :: t) -> h x F2.f1}] f2f = \ (@t) (@t1) (h :: t -> Integer -> t1) (x :: t) -> h x F2.f1 @@ -27,9 +28,9 @@ F2.f2_g [Occ=LoopBreaker] :: Integer -> Integer -> Integer [GblId, Arity=2, Str=<MU><MU>, Unf=OtherCon []] F2.f2_g = \ (x :: Integer) (y :: Integer) -> - case GHC.Num.Integer.integerCompare x F2.f1 of { + case GHC.Num.Integer.integerGt# x F2.f1 of { __DEFAULT -> y; - GT -> F2.f2_g (GHC.Num.Integer.integerSub x lvl) (GHC.Num.Integer.integerAdd x y) + 1# -> F2.f2_g (GHC.Num.Integer.integerSub x lvl) (GHC.Num.Integer.integerAdd x y) } end Rec } diff --git a/testsuite/tests/arityanal/should_compile/Arity09.stderr b/testsuite/tests/arityanal/should_compile/Arity09.stderr index 8075f7b17e..a5dfbaaab8 100644 --- a/testsuite/tests/arityanal/should_compile/Arity09.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity09.stderr @@ -23,9 +23,9 @@ F9.f91_f [Occ=LoopBreaker] :: Integer -> Integer [GblId, Arity=1, Str=<MU>, Unf=OtherCon []] F9.f91_f = \ (n :: Integer) -> - case GHC.Num.Integer.integerCompare n lvl of { - __DEFAULT -> F9.f91_f (F9.f91_f (GHC.Num.Integer.integerAdd n lvl1)); - GT -> GHC.Num.Integer.integerSub n F9.f1 + case GHC.Num.Integer.integerLe# n lvl of { + __DEFAULT -> GHC.Num.Integer.integerSub n F9.f1; + 1# -> F9.f91_f (F9.f91_f (GHC.Num.Integer.integerAdd n lvl1)) } end Rec } diff --git a/testsuite/tests/arityanal/should_compile/Arity11.stderr b/testsuite/tests/arityanal/should_compile/Arity11.stderr index 154baf01fb..fce1308cd9 100644 --- a/testsuite/tests/arityanal/should_compile/Arity11.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity11.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 129, types: 104, coercions: 0, joins: 0/5} +Result size of Tidy Core = {terms: 129, types: 94, coercions: 0, joins: 0/5} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} F11.fib1 :: Integer @@ -33,7 +33,7 @@ F11.f11_fib } end Rec } --- RHS size: {terms: 52, types: 28, coercions: 0, joins: 0/5} +-- RHS size: {terms: 52, types: 26, coercions: 0, joins: 0/5} F11.$wfib [InlPrag=[2]] :: forall {a} {p}. (a -> a -> Bool) -> (Num a, Num p) => a -> p [GblId, Arity=4, Str=<MCM(CS(U))><UP(A,UCU(CS(U)),A,A,A,A,U)><UP(UCU(CS(U)),A,A,A,A,A,1C1(U))><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}] F11.$wfib @@ -55,7 +55,7 @@ F11.$wfib [LclId] lvl3 = fromInteger @a w F11.fib1 } in letrec { - fib4 [Occ=LoopBreaker] :: a -> p + fib4 [Occ=LoopBreaker, Dmd=MCM(U)] :: a -> p [LclId, Arity=1, Str=<U>, Unf=OtherCon []] fib4 = \ (ds :: a) -> @@ -69,14 +69,14 @@ F11.$wfib }; } in fib4 w2 --- RHS size: {terms: 14, types: 21, coercions: 0, joins: 0/0} +-- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0} fib [InlPrag=[2]] :: forall {a} {p}. (Eq a, Num a, Num p) => a -> p [GblId, Arity=4, Str=<SP(MCM(CS(U)),A)><UP(A,UCU(CS(U)),A,A,A,A,U)><UP(UCU(CS(U)),A,A,A,A,A,U)><U>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) (@p) (w [Occ=Once1!] :: Eq a) (w1 [Occ=Once1] :: Num a) (w2 [Occ=Once1] :: Num p) (w3 [Occ=Once1] :: a) -> case w of { GHC.Classes.C:Eq ww1 [Occ=Once1] _ [Occ=Dead] -> F11.$wfib @a @p ww1 w1 w2 w3 }}] -fib = \ (@a) (@p) (w :: Eq a) (w1 :: Num a) (w2 :: Num p) (w3 :: a) -> case w of { GHC.Classes.C:Eq ww1 ww2 -> F11.$wfib @a @p ww1 w1 w2 w3 } + Tmpl= \ (@a) (@p) (w [Occ=Once1!] :: Eq a) (w1 [Occ=Once1] :: Num a) (w2 [Occ=Once1] :: Num p) (w3 [Occ=Once1] :: a) -> case w of { GHC.Classes.C:Eq ww [Occ=Once1] _ [Occ=Dead] -> F11.$wfib @a @p ww w1 w2 w3 }}] +fib = \ (@a) (@p) (w :: Eq a) (w1 :: Num a) (w2 :: Num p) (w3 :: a) -> case w of { GHC.Classes.C:Eq ww ww1 -> F11.$wfib @a @p ww w1 w2 w3 } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} F11.f3 :: Integer @@ -97,7 +97,7 @@ F11.f11f1 :: Integer -> Integer Tmpl= \ (y [Occ=Once1] :: Integer) -> GHC.Num.Integer.integerAdd F11.f11_x y}] F11.f11f1 = \ (y :: Integer) -> GHC.Num.Integer.integerAdd F11.f11_x y --- RHS size: {terms: 3, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} f11f :: forall {p}. p -> Integer -> Integer [GblId, Arity=2, diff --git a/testsuite/tests/arityanal/should_compile/Arity16.stderr b/testsuite/tests/arityanal/should_compile/Arity16.stderr index 5d3c83f9df..cb0b2bb8ec 100644 --- a/testsuite/tests/arityanal/should_compile/Arity16.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity16.stderr @@ -1,9 +1,9 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 52, types: 87, coercions: 0, joins: 0/0} +Result size of Tidy Core = {terms: 52, types: 75, coercions: 0, joins: 0/0} Rec { --- RHS size: {terms: 15, types: 17, coercions: 0, joins: 0/0} +-- RHS size: {terms: 15, types: 15, coercions: 0, joins: 0/0} map2 [Occ=LoopBreaker] :: forall {t} {a}. (t -> a) -> [t] -> [a] [GblId, Arity=2, Str=<U><SU>, Unf=OtherCon []] map2 @@ -19,13 +19,13 @@ lvl :: GHC.Prim.Addr# [GblId, Unf=OtherCon []] lvl = "Arity16.hs:(6,1)-(7,47)|function zipWith2"# --- RHS size: {terms: 3, types: 5, coercions: 0, joins: 0/0} +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0} lvl1 :: forall {a}. [a] [GblId, Str=b, Cpr=b] lvl1 = \ (@a) -> Control.Exception.Base.patError @'GHC.Types.LiftedRep @[a] lvl Rec { --- RHS size: {terms: 29, types: 35, coercions: 0, joins: 0/0} +-- RHS size: {terms: 29, types: 32, coercions: 0, joins: 0/0} zipWith2 [Occ=LoopBreaker] :: forall {t1} {t2} {a}. (t1 -> t2 -> a) -> [t1] -> [t2] -> [a] [GblId, Arity=3, Str=<UCU(CS(U))><SU><SU>, Unf=OtherCon []] zipWith2 diff --git a/testsuite/tests/cpranal/should_compile/T18109.hs b/testsuite/tests/cpranal/should_compile/T18109.hs new file mode 100644 index 0000000000..dad37e5e4a --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18109.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp -dno-typeable-binds #-} + +-- | These are all examples where the CPR worker should not return an unboxed +-- singleton tuple of the field, but rather the single field directly. +-- This is OK if the field indeed terminates quickly; +-- see Note [No unboxed tuple for single, unlifted transit var] +module T18109 where + +data F = F (Int -> Int) + +f :: Int -> F +f n = F (+n) +{-# NOINLINE f #-} + +data T = T (Int, Int) + +g :: T -> T +g t@(T p) = p `seq` t +{-# NOINLINE g #-} + +data U = U [Int] + +h :: U -> U +h u@(U xs) = xs `seq` u +{-# NOINLINE h #-} diff --git a/testsuite/tests/cpranal/should_compile/T18109.stderr b/testsuite/tests/cpranal/should_compile/T18109.stderr new file mode 100644 index 0000000000..7ab45af0e6 --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18109.stderr @@ -0,0 +1,30 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 39, types: 43, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 2, types: 3, coercions: 0, joins: 0/0} +T18109.$wg :: (Int, Int) -> (Int, Int) +T18109.$wg = \ (ww_sFZ :: (Int, Int)) -> ww_sFZ + +-- RHS size: {terms: 10, types: 10, coercions: 0, joins: 0/0} +g :: T -> T +g = \ (w_sFW :: T) -> case w_sFW of { T ww1_sFZ -> case T18109.$wg ww1_sFZ of ww2_sG4 { (ipv_sGq, ipv1_sGr) -> T18109.T ww2_sG4 } } + +-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} +T18109.$wh :: [Int] -> [Int] +T18109.$wh = \ (ww_sG9 :: [Int]) -> ww_sG9 + +-- RHS size: {terms: 10, types: 6, coercions: 0, joins: 0/0} +h :: U -> U +h = \ (w_sG6 :: U) -> case w_sG6 of { U ww1_sG9 -> case T18109.$wh ww1_sG9 of ww2_sGe { __DEFAULT -> T18109.U ww2_sGe } } + +-- RHS size: {terms: 5, types: 2, coercions: 0, joins: 0/0} +T18109.$wf :: Int -> Int -> Int +T18109.$wf = \ (w_sGg :: Int) (eta_B0 :: Int) -> GHC.Num.$fNumInt_$c+ eta_B0 w_sGg + +-- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} +f :: Int -> F +f = \ (w_sGg :: Int) -> T18109.F (T18109.$wf w_sGg) + + + diff --git a/testsuite/tests/cpranal/should_compile/T18174.hs b/testsuite/tests/cpranal/should_compile/T18174.hs new file mode 100644 index 0000000000..aec64933ab --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18174.hs @@ -0,0 +1,82 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} +{-# LANGUAGE BangPatterns #-} + +module T18174 (fac1, fac2, fac3, facIO, h1, h2) where + +---------------------------------------------------------------------- +-- First some basic examples that we want to CPR nestedly. + +-- pretty strict +fac1 :: Int -> a -> (a, Int) +fac1 n s | n < 2 = (s,1) + | otherwise = case fac1 (n-1) s of (s',n') -> let n'' = n*n' in n'' `seq` (s',n'') + +-- lazier, but Int still has CPR +fac2 :: Int -> a -> (a, Int) +fac2 n s | n < 2 = (s,1) + | otherwise = case fac2 (n-1) s of (s',n') -> (s',n'*n') + +-- even lazier, but evaluation of the Int doesn't terminate rapidly! +-- Thus, we may not WW for the nested Int. +-- Otherwise @fac3 99999 () `seq` ()@ (which should terminate rapidly) +-- evaluates more than necessary. +fac3 :: Int -> a -> (a, Int) +fac3 n s | n < 2 = (s,1) + | otherwise = let (s',n') = fac3 (n-1) s in (s',n'*n') + +facIO :: Int -> IO Int +facIO n | n < 2 = return 1 + | otherwise = do n' <- facIO (n-1); return (n*n') + +-- Now some checks wrt. strict fields where we don't want to unbox. + +data T = MkT Int !(Int, Int) + +-- | Should not unbox any component, because the wrapper of 'MkT' forces +-- 'p', which this function is lazy in. Similarly for 'x'. +dataConWrapper :: (Int, Int) -> Int -> (T, Int) +dataConWrapper p x = (MkT x p, x+1) +{-# NOINLINE dataConWrapper #-} + +-- | Should not unbox the second component, because 'x' won't be available +-- unboxed. It terminates, though. +strictField :: T -> (Int, (Int, Int)) +strictField (MkT x y) = (x, y) +{-# NOINLINE strictField #-} + +---------------------------------------------------------------------- +-- The following functions are copied from T18894. This test is about +-- *exploiting* the demand signatures that we assertedly (by T18894) +-- annotate. + +g1 :: Int -> (Int,Int) +g1 1 = (15, 0) +g1 n = (2 * n, 2 `div` n) +{-# NOINLINE g1 #-} + +-- | Sadly, the @g1 2@ subexpression will be floated to top-level, where we +-- don't see the specific demand placed on it by @snd@. Tracked in #19001. +h1 :: Int -> Int +h1 1 = 0 +h1 2 = snd (g1 2) +h1 m = uncurry (+) (g1 m) + +-- | So @g2@ here takes an additional argument m that prohibits floating to +-- top-level. We want that argument to have the CPR property, so we have +-- to add a bang so that it's used strictly and ultimately unboxed. +-- We expect the following CPR type: +-- +-- > #c1(#c1(#), *c1(#)) +-- +-- In combination with the the fact that all calls to @g2@ evaluate the second +-- component of the pair, we may unbox @g2@ to @(# Int#, Int# #)@. +g2 :: Int -> Int -> (Int,Int) +g2 !m 1 = (2 + m, 0) +g2 m n = (2 * m, 2 `div` n) +{-# NOINLINE g2 #-} + +h2 :: Int -> Int +h2 1 = 0 +h2 m + | odd m = snd (g2 m 2) + | otherwise = uncurry (+) (g2 2 m) diff --git a/testsuite/tests/cpranal/should_compile/T18174.stderr b/testsuite/tests/cpranal/should_compile/T18174.stderr new file mode 100644 index 0000000000..58e16dea37 --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18174.stderr @@ -0,0 +1,167 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 336, types: 354, coercions: 6, joins: 0/1} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule4 :: GHC.Prim.Addr# +T18174.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule3 :: GHC.Types.TrName +T18174.$trModule3 = GHC.Types.TrNameS T18174.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule2 :: GHC.Prim.Addr# +T18174.$trModule2 = "T18174"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule1 :: GHC.Types.TrName +T18174.$trModule1 = GHC.Types.TrNameS T18174.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule :: GHC.Types.Module +T18174.$trModule = GHC.Types.Module T18174.$trModule3 T18174.$trModule1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl_r1mo :: Int +lvl_r1mo = GHC.Types.I# 1# + +Rec { +-- RHS size: {terms: 38, types: 37, coercions: 0, joins: 0/1} +T18174.$wfac3 :: forall {a}. GHC.Prim.Int# -> a -> (# a, Int #) +T18174.$wfac3 + = \ (@a_s1cY) (ww_s1d2 :: GHC.Prim.Int#) (w_s1d0 :: a_s1cY) -> + case GHC.Prim.<# ww_s1d2 2# of { + __DEFAULT -> + let { + ds_s181 :: (a_s1cY, Int) + ds_s181 = case T18174.$wfac3 @a_s1cY (GHC.Prim.-# ww_s1d2 1#) w_s1d0 of { (# ww1_s1d6, ww2_s1d7 #) -> (ww1_s1d6, ww2_s1d7) } } in + (# case ds_s181 of { (s'_aX6, n'_aX7) -> s'_aX6 }, case ds_s181 of { (s'_aX6, n'_aX7) -> case n'_aX7 of { GHC.Types.I# ww1_s1cW -> GHC.Types.I# (GHC.Prim.*# ww1_s1cW ww1_s1cW) } } #); + 1# -> (# w_s1d0, lvl_r1mo #) + } +end Rec } + +-- RHS size: {terms: 14, types: 15, coercions: 0, joins: 0/0} +fac3 :: forall a. Int -> a -> (a, Int) +fac3 = \ (@a_s1cY) (w_s1cZ :: Int) (w1_s1d0 :: a_s1cY) -> case w_s1cZ of { GHC.Types.I# ww_s1d2 -> case T18174.$wfac3 @a_s1cY ww_s1d2 w1_s1d0 of { (# ww1_s1d6, ww2_s1d7 #) -> (ww1_s1d6, ww2_s1d7) } } + +Rec { +-- RHS size: {terms: 24, types: 20, coercions: 0, joins: 0/0} +T18174.$wfac2 :: forall {a}. GHC.Prim.Int# -> a -> (# a, GHC.Prim.Int# #) +T18174.$wfac2 + = \ (@a_s1d9) (ww_s1dd :: GHC.Prim.Int#) (w_s1db :: a_s1d9) -> + case GHC.Prim.<# ww_s1dd 2# of { + __DEFAULT -> case T18174.$wfac2 @a_s1d9 (GHC.Prim.-# ww_s1dd 1#) w_s1db of { (# ww1_s1dh, ww2_s1dk #) -> (# ww1_s1dh, GHC.Prim.*# ww2_s1dk ww2_s1dk #) }; + 1# -> (# w_s1db, 1# #) + } +end Rec } + +-- RHS size: {terms: 15, types: 15, coercions: 0, joins: 0/0} +fac2 :: forall a. Int -> a -> (a, Int) +fac2 = \ (@a_s1d9) (w_s1da :: Int) (w1_s1db :: a_s1d9) -> case w_s1da of { GHC.Types.I# ww_s1dd -> case T18174.$wfac2 @a_s1d9 ww_s1dd w1_s1db of { (# ww1_s1dh, ww2_s1dk #) -> (ww1_s1dh, GHC.Types.I# ww2_s1dk) } } + +Rec { +-- RHS size: {terms: 24, types: 20, coercions: 0, joins: 0/0} +T18174.$wfac1 :: forall {a}. GHC.Prim.Int# -> a -> (# a, GHC.Prim.Int# #) +T18174.$wfac1 + = \ (@a_s1dm) (ww_s1dq :: GHC.Prim.Int#) (w_s1do :: a_s1dm) -> + case GHC.Prim.<# ww_s1dq 2# of { + __DEFAULT -> case T18174.$wfac1 @a_s1dm (GHC.Prim.-# ww_s1dq 1#) w_s1do of { (# ww1_s1du, ww2_s1dx #) -> (# ww1_s1du, GHC.Prim.*# ww_s1dq ww2_s1dx #) }; + 1# -> (# w_s1do, 1# #) + } +end Rec } + +-- RHS size: {terms: 15, types: 15, coercions: 0, joins: 0/0} +fac1 :: forall a. Int -> a -> (a, Int) +fac1 = \ (@a_s1dm) (w_s1dn :: Int) (w1_s1do :: a_s1dm) -> case w_s1dn of { GHC.Types.I# ww_s1dq -> case T18174.$wfac1 @a_s1dm ww_s1dq w1_s1do of { (# ww1_s1du, ww2_s1dx #) -> (ww1_s1du, GHC.Types.I# ww2_s1dx) } } + +-- RHS size: {terms: 30, types: 18, coercions: 0, joins: 0/0} +T18174.$wg2 :: GHC.Prim.Int# -> GHC.Prim.Int# -> (# GHC.Prim.Int#, GHC.Prim.Int# #) +T18174.$wg2 + = \ (ww_s1dC :: GHC.Prim.Int#) (ww1_s1dF :: GHC.Prim.Int#) -> + case ww1_s1dF of ds_X2 { + __DEFAULT -> case GHC.Classes.divInt# 2# ds_X2 of ww2_a14Y { __DEFAULT -> (# GHC.Prim.*# 2# ww_s1dC, ww2_a14Y #) }; + -1# -> (# GHC.Prim.*# 2# ww_s1dC, -2# #); + 0# -> case GHC.Real.divZeroError of wild_00 { }; + 1# -> (# GHC.Prim.+# 2# ww_s1dC, 0# #) + } + +-- RHS size: {terms: 26, types: 17, coercions: 0, joins: 0/0} +T18174.$wh2 :: GHC.Prim.Int# -> GHC.Prim.Int# +T18174.$wh2 + = \ (ww_s1dS :: GHC.Prim.Int#) -> + case ww_s1dS of ds_X2 { + __DEFAULT -> + case GHC.Prim.remInt# ds_X2 2# of { + __DEFAULT -> case T18174.$wg2 ds_X2 2# of { (# ww1_s1dL, ww2_s1dO #) -> ww2_s1dO }; + 0# -> case T18174.$wg2 2# ds_X2 of { (# ww1_s1dL, ww2_s1dO #) -> GHC.Prim.+# ww1_s1dL ww2_s1dO } + }; + 1# -> 0# + } + +-- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0} +h2 :: Int -> Int +h2 = \ (w_s1dQ :: Int) -> case w_s1dQ of { GHC.Types.I# ww_s1dS -> case T18174.$wh2 ww_s1dS of ww1_s1dW { __DEFAULT -> GHC.Types.I# ww1_s1dW } } + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.h5 :: Int +T18174.h5 = GHC.Types.I# 0# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl1_r1mp :: Int +lvl1_r1mp = GHC.Types.I# -2# + +-- RHS size: {terms: 27, types: 14, coercions: 0, joins: 0/0} +T18174.$wg1 :: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) +T18174.$wg1 + = \ (ww_s1e0 :: GHC.Prim.Int#) -> + case ww_s1e0 of ds_X2 { + __DEFAULT -> + (# GHC.Prim.*# 2# ds_X2, + case ds_X2 of { + __DEFAULT -> case GHC.Classes.divInt# 2# ds_X2 of ww2_a14Y { __DEFAULT -> GHC.Types.I# ww2_a14Y }; + -1# -> lvl1_r1mp; + 0# -> case GHC.Real.divZeroError of wild_00 { } + } #); + 1# -> (# 15#, T18174.h5 #) + } + +-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} +T18174.h4 :: (Int, Int) +T18174.h4 = case T18174.$wg1 2# of { (# ww_s1e6, ww1_s1e7 #) -> (GHC.Types.I# ww_s1e6, ww1_s1e7) } + +-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0} +T18174.$wh1 :: GHC.Prim.Int# -> Int +T18174.$wh1 + = \ (ww_s1eb :: GHC.Prim.Int#) -> + case ww_s1eb of ds_X2 { + __DEFAULT -> case T18174.$wg1 ds_X2 of { (# ww1_s1e6, ww2_s1e7 #) -> case ww2_s1e7 of { GHC.Types.I# y_a159 -> GHC.Types.I# (GHC.Prim.+# ww1_s1e6 y_a159) } }; + 1# -> T18174.h5; + 2# -> case T18174.h4 of { (ds1_a132, y_a133) -> y_a133 } + } + +-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +h1 :: Int -> Int +h1 = \ (w_s1e9 :: Int) -> case w_s1e9 of { GHC.Types.I# ww_s1eb -> T18174.$wh1 ww_s1eb } + +Rec { +-- RHS size: {terms: 23, types: 29, coercions: 0, joins: 0/0} +T18174.$wfacIO :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) +T18174.$wfacIO + = \ (ww_s1ei :: GHC.Prim.Int#) (w_s1eg :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case GHC.Prim.<# ww_s1ei 2# of { + __DEFAULT -> case T18174.$wfacIO (GHC.Prim.-# ww_s1ei 1#) w_s1eg of { (# ww1_s1em, ww2_s1ep #) -> (# ww1_s1em, GHC.Prim.*# ww_s1ei ww2_s1ep #) }; + 1# -> (# w_s1eg, 1# #) + } +end Rec } + +-- RHS size: {terms: 14, types: 23, coercions: 0, joins: 0/0} +T18174.facIO1 :: Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) +T18174.facIO1 = \ (w_s1ef :: Int) (w1_s1eg :: GHC.Prim.State# GHC.Prim.RealWorld) -> case w_s1ef of { GHC.Types.I# ww_s1ei -> case T18174.$wfacIO ww_s1ei w1_s1eg of { (# ww1_s1em, ww2_s1ep #) -> (# ww1_s1em, GHC.Types.I# ww2_s1ep #) } } + +-- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0} +facIO :: Int -> IO Int +facIO = T18174.facIO1 `cast` (<Int>_R %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) + + + diff --git a/testsuite/tests/cpranal/should_compile/T18401.hs b/testsuite/tests/cpranal/should_compile/T18401.hs new file mode 100644 index 0000000000..c850d9a7e0 --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18401.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp -dno-typeable-binds #-} + +module T18401 where + +-- | A safe version of `init`. +-- @safeInit [] = Nothing@ +-- @safeInit xs = Just $ init xs@ +safeInit :: [a] -> Maybe [a] +safeInit xs = case si xs of + (False, _) -> Nothing + (_, ys) -> Just ys + +si :: [a] -> (Bool, [a]) +si xs0 = foldr go stop xs0 Nothing + where + stop Nothing = (False, []) + stop _ = (True, []) + go x r Nothing = (True, snd (r (Just x))) + go x r (Just p) = (True, p : snd (r (Just x))) + diff --git a/testsuite/tests/cpranal/should_compile/T18401.stderr b/testsuite/tests/cpranal/should_compile/T18401.stderr new file mode 100644 index 0000000000..e953034eec --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18401.stderr @@ -0,0 +1,39 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 53, types: 82, coercions: 0, joins: 0/0} + +Rec { +-- RHS size: {terms: 13, types: 12, coercions: 0, joins: 0/0} +T18401.$w$spoly_$wgo1 :: forall {a}. a -> [a] -> [a] +T18401.$w$spoly_$wgo1 + = \ (@a_s1bM) (w_s1bN :: a_s1bM) (w1_s1bO :: [a_s1bM]) -> + case w1_s1bO of { + [] -> GHC.Types.[] @a_s1bM; + : y_a151 ys_a152 -> GHC.Types.: @a_s1bM w_s1bN (T18401.$w$spoly_$wgo1 @a_s1bM y_a151 ys_a152) + } +end Rec } + +-- RHS size: {terms: 11, types: 12, coercions: 0, joins: 0/0} +T18401.safeInit_$spoly_$wgo1 :: forall {a}. a -> [a] -> (# Bool, [a] #) +T18401.safeInit_$spoly_$wgo1 = \ (@a_s1bM) (w_s1bN :: a_s1bM) (w1_s1bO :: [a_s1bM]) -> case T18401.$w$spoly_$wgo1 @a_s1bM w_s1bN w1_s1bO of ww_s1bT { __DEFAULT -> (# GHC.Types.True, ww_s1bT #) } + +-- RHS size: {terms: 14, types: 16, coercions: 0, joins: 0/0} +si :: forall a. [a] -> (Bool, [a]) +si + = \ (@a_s18u) (w_s18v :: [a_s18u]) -> + case w_s18v of { + [] -> (GHC.Types.False, GHC.Types.[] @a_s18u); + : y_a151 ys_a152 -> (GHC.Types.True, T18401.$w$spoly_$wgo1 @a_s18u y_a151 ys_a152) + } + +-- RHS size: {terms: 11, types: 13, coercions: 0, joins: 0/0} +safeInit :: forall a. [a] -> Maybe [a] +safeInit + = \ (@a_aNp) (xs_au5 :: [a_aNp]) -> + case xs_au5 of { + [] -> GHC.Maybe.Nothing @[a_aNp]; + : y_a151 ys_a152 -> GHC.Maybe.Just @[a_aNp] (T18401.$w$spoly_$wgo1 @a_aNp y_a151 ys_a152) + } + + + diff --git a/testsuite/tests/cpranal/should_compile/all.T b/testsuite/tests/cpranal/should_compile/all.T index 5a37f42376..7c0f6a7a4e 100644 --- a/testsuite/tests/cpranal/should_compile/all.T +++ b/testsuite/tests/cpranal/should_compile/all.T @@ -5,3 +5,8 @@ def f( name, opts ): setTestOpts(f) test('Cpr001', [], multimod_compile, ['Cpr001', '-v0']) +# The following tests grep for type signatures of worker functions. +test('T18109', [ grep_errmsg(r'^T18109\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999']) +test('T18174', [ grep_errmsg(r'^T18174\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999']) +# NB: T18401 currently needs -flate-dmd-anal so that it runs after SpecConstr +test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999 -flate-dmd-anal']) diff --git a/testsuite/tests/stranal/sigs/CaseBinderCPR.hs b/testsuite/tests/cpranal/sigs/CaseBinderCPR.hs index 13f216347d..1310031f42 100644 --- a/testsuite/tests/stranal/sigs/CaseBinderCPR.hs +++ b/testsuite/tests/cpranal/sigs/CaseBinderCPR.hs @@ -13,3 +13,9 @@ f_list_cmp a_cmp (a_x:a_xs) (a_y:a_ys)= else r_order where r_order = a_cmp a_x a_y + + +-- But not every case binder has the CPR property. +-- x below does not and we should not CPR nestedly for it: +g :: [Int] -> (Int, Int) +g xs = let x = xs !! 0 in x `seq` (x, x) diff --git a/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr new file mode 100644 index 0000000000..7aa1cb98f7 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr @@ -0,0 +1,14 @@ + +==================== Term signatures ==================== +CaseBinderCPR.$trModule: * +CaseBinderCPR.f_list_cmp: * +CaseBinderCPR.g: *1(#, #) + + + +==================== Cpr signatures ==================== +CaseBinderCPR.$trModule: +CaseBinderCPR.f_list_cmp: +CaseBinderCPR.g: 1 + + diff --git a/testsuite/tests/stranal/sigs/FacState.hs b/testsuite/tests/cpranal/sigs/FacState.hs index 470bbd9dcb..470bbd9dcb 100644 --- a/testsuite/tests/stranal/sigs/FacState.hs +++ b/testsuite/tests/cpranal/sigs/FacState.hs diff --git a/testsuite/tests/cpranal/sigs/FacState.stderr b/testsuite/tests/cpranal/sigs/FacState.stderr new file mode 100644 index 0000000000..9886eda340 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/FacState.stderr @@ -0,0 +1,12 @@ + +==================== Term signatures ==================== +FacState.$trModule: * +FacState.fac: *1(*, #1(#)) + + + +==================== Cpr signatures ==================== +FacState.$trModule: +FacState.fac: 1(, 1) + + diff --git a/testsuite/tests/cpranal/sigs/Makefile b/testsuite/tests/cpranal/sigs/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/cpranal/sigs/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/stranal/should_compile/T10694.hs b/testsuite/tests/cpranal/sigs/T10694.hs index b18e9261e0..b18e9261e0 100644 --- a/testsuite/tests/stranal/should_compile/T10694.hs +++ b/testsuite/tests/cpranal/sigs/T10694.hs diff --git a/testsuite/tests/cpranal/sigs/T10694.stderr b/testsuite/tests/cpranal/sigs/T10694.stderr new file mode 100644 index 0000000000..3cbf350d72 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/T10694.stderr @@ -0,0 +1,14 @@ + +==================== Term signatures ==================== +T10694.$trModule: * +T10694.m: * +T10694.pm: # + + + +==================== Cpr signatures ==================== +T10694.$trModule: +T10694.m: +T10694.pm: 1 + + diff --git a/testsuite/tests/cpranal/sigs/T1600.hs b/testsuite/tests/cpranal/sigs/T1600.hs new file mode 100644 index 0000000000..330ded7500 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/T1600.hs @@ -0,0 +1,6 @@ +-- | Basically tests Nested CPR on IO. +module T1600 where + +facIO :: Int -> IO Int +facIO n | n < 2 = return 1 + | otherwise = do n' <- facIO (n-1); return (n*n') diff --git a/testsuite/tests/cpranal/sigs/T1600.stderr b/testsuite/tests/cpranal/sigs/T1600.stderr new file mode 100644 index 0000000000..5bcdf2e5bd --- /dev/null +++ b/testsuite/tests/cpranal/sigs/T1600.stderr @@ -0,0 +1,12 @@ + +==================== Term signatures ==================== +T1600.$trModule: * +T1600.facIO: *1(*, #1(#)) + + + +==================== Cpr signatures ==================== +T1600.$trModule: +T1600.facIO: 1(, 1) + + diff --git a/testsuite/tests/stranal/sigs/T5075.hs b/testsuite/tests/cpranal/sigs/T5075.hs index c35409aa67..c35409aa67 100644 --- a/testsuite/tests/stranal/sigs/T5075.hs +++ b/testsuite/tests/cpranal/sigs/T5075.hs diff --git a/testsuite/tests/cpranal/sigs/T5075.stderr b/testsuite/tests/cpranal/sigs/T5075.stderr new file mode 100644 index 0000000000..78657e43c5 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/T5075.stderr @@ -0,0 +1,12 @@ + +==================== Term signatures ==================== +T5075.$trModule: * +T5075.loop: * + + + +==================== Cpr signatures ==================== +T5075.$trModule: +T5075.loop: + + diff --git a/testsuite/tests/cpranal/sigs/TrimCpr.hs b/testsuite/tests/cpranal/sigs/TrimCpr.hs new file mode 100644 index 0000000000..b1fe7d75ef --- /dev/null +++ b/testsuite/tests/cpranal/sigs/TrimCpr.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE GADTs #-} + +module TrimCpr where + +expensive :: Int -> Bool +expensive = even +{-# NOINLINE expensive #-} + +-- | Should *not* have the CPR property, because it has arity 1. +trimByArity :: Int -> Int -> Maybe Int +trimByArity x + | expensive x = \y -> Just (x+y) + | otherwise = \y -> Just y +{-# NOINLINE trimByArity #-} + +data T a where + A :: T Int + B :: T (Int -> Int) + +-- | If we say `LLb` for 'g', this will get the CPR property, which is wrong. +trimByArity2 :: Int -> Int -> Int +trimByArity2 0 y = y + 1 +trimByArity2 x y = g B (x+y) + where + g :: T a -> a + g A = error "A" + g B = \_ -> error "B" + {-# NOINLINE g #-} + +-- | Should *not* have the CPR property, because evaluation of `blah` won't +-- terminate and `f` won't have the nested CPR property. +trimByTerm :: Int -> Int +trimByTerm n + | n < 0 = n + | otherwise = case f n of Just blah -> blah + where + f :: Int -> Maybe Int + f n = Just (sum [0..n]) + {-# NOINLINE f #-} +{-# NOINLINE trimByTerm #-} diff --git a/testsuite/tests/cpranal/sigs/TrimCpr.stderr b/testsuite/tests/cpranal/sigs/TrimCpr.stderr new file mode 100644 index 0000000000..4ef89ab64f --- /dev/null +++ b/testsuite/tests/cpranal/sigs/TrimCpr.stderr @@ -0,0 +1,24 @@ + +==================== Term signatures ==================== +TrimCpr.$tc'A: * +TrimCpr.$tc'B: * +TrimCpr.$tcT: * +TrimCpr.$trModule: * +TrimCpr.expensive: * +TrimCpr.trimByArity: *L# +TrimCpr.trimByArity2: *1(#) +TrimCpr.trimByTerm: * + + + +==================== Cpr signatures ==================== +TrimCpr.$tc'A: +TrimCpr.$tc'B: +TrimCpr.$tcT: +TrimCpr.$trModule: +TrimCpr.expensive: +TrimCpr.trimByArity: +TrimCpr.trimByArity2: +TrimCpr.trimByTerm: + + diff --git a/testsuite/tests/cpranal/sigs/all.T b/testsuite/tests/cpranal/sigs/all.T new file mode 100644 index 0000000000..2f66f4c915 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/all.T @@ -0,0 +1,15 @@ +# This directory contains tests where we annotate functions with expected +# cpr signatures, and verify that these are actually found by the compiler + +setTestOpts(extra_hc_opts('-ddump-cpr-signatures')) + +# We are testing the result of an optimization, so no use +# running them in various runtimes +setTestOpts(only_ways(['optasm'])) + +test('FacState', normal, compile, ['']) +test('CaseBinderCPR', normal, compile, ['']) +test('T5075', normal, compile, ['']) +test('T10694', normal, compile, ['']) +test('T1600', normal, compile, ['']) +test('TrimCpr', normal, compile, ['']) diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 6e7df6c5de..4ff726d380 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -7,7 +7,6 @@ Result size of Tidy Core T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a [GblId[DataConWrapper], Caf=NoCafRefs, - Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False) @@ -17,7 +16,7 @@ T2431.$WRefl -- RHS size: {terms: 4, types: 7, coercions: 0, joins: 0/0} absurd :: forall a. (Int :~: Bool) -> a -[GblId, Arity=1, Str=<U>b, Cpr=b, Unf=OtherCon []] +[GblId, Arity=1, Str=<U>b, Term=*(#..), Cpr=b, Unf=OtherCon []] absurd = \ (@a) (x :: Int :~: Bool) -> case x of { } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/lib/integer/Makefile b/testsuite/tests/lib/integer/Makefile index 4292a1b970..f8ab33ebcc 100644 --- a/testsuite/tests/lib/integer/Makefile +++ b/testsuite/tests/lib/integer/Makefile @@ -11,7 +11,7 @@ CHECK2 = grep -q -- '$1' folding.simpl || \ .PHONY: integerConstantFolding integerConstantFolding: - '$(TEST_HC)' -Wall -v0 -O --make integerConstantFolding -fforce-recomp -ddump-simpl > folding.simpl + '$(TEST_HC)' -Wall -v0 -O --make integerConstantFolding -fforce-recomp -dno-debug-output -ddump-simpl > folding.simpl # All the 100nnn values should be constant-folded away ! grep -q '\<100[0-9][0-9][0-9]\>' folding.simpl || { echo "Unfolded values found"; grep '\<100[0-9][0-9][0-9]\>' folding.simpl; } $(call CHECK,\<200007\>,plusInteger) @@ -44,7 +44,7 @@ integerConstantFolding: .PHONY: fromToInteger fromToInteger: - '$(TEST_HC)' -Wall -v0 -O -c fromToInteger.hs -fforce-recomp -ddump-simpl > fromToInteger.simpl + '$(TEST_HC)' -Wall -v0 -O -c fromToInteger.hs -fforce-recomp -dno-debug-output -ddump-simpl > fromToInteger.simpl # Rules should eliminate all functions -grep integerToInt fromToInteger.simpl -grep smallInteger fromToInteger.simpl @@ -53,7 +53,7 @@ fromToInteger: .PHONY: IntegerConversionRules IntegerConversionRules: - '$(TEST_HC)' -Wall -v0 -O -c $@.hs -fforce-recomp -ddump-simpl > $@.simpl + '$(TEST_HC)' -Wall -v0 -O -c $@.hs -fforce-recomp -dno-debug-output -ddump-simpl > $@.simpl -grep -q smallInteger $@.simpl && echo "smallInteger present" -grep -q doubleFromInteger $@.simpl && echo "doubleFromInteger present" -grep -q int2Double $@.simpl || echo "int2Double absent" diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout index b493cee119..30b9495e63 100644 --- a/testsuite/tests/numeric/should_compile/T14465.stdout +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -55,6 +55,7 @@ M.minusOne1 = 1 -- RHS size: {terms: 6, types: 1, coercions: 0, joins: 0/0} minusOne :: Natural [GblId, + Term=*1(#), Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 10}] minusOne diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 996d391b44..be2950bbc6 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -44,7 +44,8 @@ dr :: Double -> Double [GblId, Arity=1, Str=<SP(U)>, - Cpr=m1, + Term=#1(#), + 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 +62,8 @@ dl :: Double -> Double [GblId, Arity=1, Str=<SP(U)>, - Cpr=m1, + Term=#1(#), + 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) @@ -74,7 +76,8 @@ fr :: Float -> Float [GblId, Arity=1, Str=<SP(U)>, - Cpr=m1, + Term=#1(#), + 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) @@ -93,7 +96,8 @@ fl :: Float -> Float [GblId, Arity=1, Str=<SP(U)>, - Cpr=m1, + Term=#1(#), + 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/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index 8c96acf235..3f5af335e4 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -1,4 +1,4 @@ -Found 238 Language.Haskell.Syntax module dependencies +Found 240 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -175,8 +175,10 @@ GHC.Types.SourceFile GHC.Types.SourceText GHC.Types.SrcLoc GHC.Types.Target +GHC.Types.Termination GHC.Types.TyThing GHC.Types.TypeEnv +GHC.Types.Unbox GHC.Types.Unique GHC.Types.Unique.DFM GHC.Types.Unique.DSet diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 81d67c92ae..533ad4a8d7 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 246 GHC.Parser module dependencies +Found 248 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -183,8 +183,10 @@ GHC.Types.SourceFile GHC.Types.SourceText GHC.Types.SrcLoc GHC.Types.Target +GHC.Types.Termination GHC.Types.TyThing GHC.Types.TypeEnv +GHC.Types.Unbox GHC.Types.Unique GHC.Types.Unique.DFM GHC.Types.Unique.DSet diff --git a/testsuite/tests/plugins/plugin-recomp-change.stderr b/testsuite/tests/plugins/plugin-recomp-change.stderr index 91747c8b7d..e2a27f1903 100644 --- a/testsuite/tests/plugins/plugin-recomp-change.stderr +++ b/testsuite/tests/plugins/plugin-recomp-change.stderr @@ -1,6 +1,6 @@ Simple Plugin Passes Queried -Got options: +Got options: Simple Plugin Pass Run Simple Plugin Passes Queried -Got options: +Got options: Simple Plugin Pass Run 2 diff --git a/testsuite/tests/rts/T5644/ManyQueue.hs b/testsuite/tests/rts/T5644/ManyQueue.hs index d2a6882d6c..ded8b62f1a 100644 --- a/testsuite/tests/rts/T5644/ManyQueue.hs +++ b/testsuite/tests/rts/T5644/ManyQueue.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -module ManyQueue where +module ManyQueue where import Control.Concurrent import Control.Monad @@ -23,17 +23,17 @@ readMQueue (MQueue (x:xs)) = do el <- takeMVar x return ((MQueue xs), el) +elements :: [Int] +elements = [0] ++ [1 .. iTERATIONS] -- workaround +-- elements = [0 .. iTERATIONS] -- heap overflow + testManyQueue'1P1C = do print "Test.ManyQueue.testManyQueue'1P1C" finished <- newEmptyMVar mq <- newMQueue bufferSize - - let --- elements = [0] ++ [1 .. iTERATIONS] -- workaround - elements = [0 .. iTERATIONS] -- heap overflow - - writer _ 0 = putMVar finished () + + let writer _ 0 = putMVar finished () writer q x = do q' <- writeMQueue q x writer q' (x-1) @@ -47,7 +47,7 @@ testManyQueue'1P1C = do reader q !acc n = do (q', x) <- readMQueue q reader q' (acc+x) (n-1) - + --forkIO $ writer mq iTERATIONS forkIO $ writer' mq elements forkIO $ reader mq 0 iTERATIONS @@ -61,10 +61,8 @@ testManyQueue'1P3C = do finished <- newEmptyMVar mqs <- replicateM tCount (newMQueue bufferSize) - - let elements = [0 .. iTERATIONS] - - writer _ [] = putMVar finished () + + let writer _ [] = putMVar finished () writer qs (x:xs) = do qs' <- mapM (\q -> writeMQueue q x) qs writer qs' xs @@ -73,10 +71,10 @@ testManyQueue'1P3C = do reader q !acc n = do (q', x) <- readMQueue q reader q' (acc+x) (n-1) - + forkIO $ writer mqs elements mapM_ (\ mq -> forkIO $ reader mq 0 iTERATIONS) mqs replicateM (tCount+1) (takeMVar finished) - return ()
\ No newline at end of file + return () diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index 3712fd5477..0d77df10c9 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -82,7 +82,7 @@ T11155: T8274: $(RM) -f T8274.o T8274.hi # Set -dppr-cols to ensure things don't wrap - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques -dsuppress-ticks -dppr-cols=200 T8274.hs | grep '#' + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-idinfo -dsuppress-uniques -dsuppress-ticks -dppr-cols=200 T8274.hs | grep '#' T7865: $(RM) -f T7865.o T7865.hi diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr index c2bc42a872..0f59fbbe1a 100644 --- a/testsuite/tests/simplCore/should_compile/T13143.stderr +++ b/testsuite/tests/simplCore/should_compile/T13143.stderr @@ -7,7 +7,7 @@ Rec { -- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0} T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker] :: forall {a}. (# #) -> a -[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []] +[GblId, Arity=1, Str=<B>b, Term=*(#..), Cpr=b, Unf=OtherCon []] T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##) end Rec } @@ -16,6 +16,7 @@ f [InlPrag=[final]] :: forall a. Int -> a [GblId, Arity=1, Str=<B>b, + Term=*(#..), Cpr=b, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -90,21 +91,22 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int [GblId, Arity=3, Str=<SU><SU><SP(U)>, - Cpr=m1, + Term=*1(#), + 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) Tmpl= \ (w [Occ=Once1] :: Bool) (w1 [Occ=Once1] :: Bool) (w2 [Occ=Once1!] :: Int) -> - case w2 of { GHC.Types.I# ww1 [Occ=Once1] -> - case T13143.$wg w w1 ww1 of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case w2 of { GHC.Types.I# ww [Occ=Once1] -> + case T13143.$wg w w1 ww of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } }}] g = \ (w :: Bool) (w1 :: Bool) (w2 :: Int) -> - case w2 of { GHC.Types.I# ww1 -> - case T13143.$wg w w1 ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } + case w2 of { GHC.Types.I# ww -> + case T13143.$wg w w1 ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T13543.stderr b/testsuite/tests/simplCore/should_compile/T13543.stderr index ce5b23ff4a..30c65e99a4 100644 --- a/testsuite/tests/simplCore/should_compile/T13543.stderr +++ b/testsuite/tests/simplCore/should_compile/T13543.stderr @@ -6,10 +6,17 @@ Foo.g: <SP(SP(U),SP(U))> +==================== Term signatures ==================== +Foo.$trModule: * +Foo.f: #1(#) +Foo.g: #1(#) + + + ==================== Cpr signatures ==================== Foo.$trModule: -Foo.f: m1 -Foo.g: m1 +Foo.f: 1 +Foo.g: 1 diff --git a/testsuite/tests/simplCore/should_compile/T15631.stdout b/testsuite/tests/simplCore/should_compile/T15631.stdout index cce6777d74..e9e6a2bcab 100644 --- a/testsuite/tests/simplCore/should_compile/T15631.stdout +++ b/testsuite/tests/simplCore/should_compile/T15631.stdout @@ -1,7 +1,7 @@ case GHC.List.$wlenAcc - case GHC.List.$wlenAcc @a w 0# of ww2 { __DEFAULT -> + case GHC.List.$wlenAcc @a w 0# of ww1 { __DEFAULT -> case GHC.List.reverse1 @a w (GHC.Types.[] @a) of { - [] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww2 v1 }; + [] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww1 v1 }; case GHC.List.$wlenAcc case Foo.$wf @a w of ww [Occ=Once1] { __DEFAULT -> case Foo.$wf @a w of ww { __DEFAULT -> GHC.Types.I# ww } diff --git a/testsuite/tests/simplCore/should_compile/T17673.stderr b/testsuite/tests/simplCore/should_compile/T17673.stderr index e3e993c8de..4af5667397 100644 --- a/testsuite/tests/simplCore/should_compile/T17673.stderr +++ b/testsuite/tests/simplCore/should_compile/T17673.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 56, types: 67, coercions: 5, joins: 0/0} +Result size of Tidy Core = {terms: 55, types: 82, coercions: 6, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T17673.$trModule4 :: GHC.Prim.Addr# @@ -9,7 +9,7 @@ T17673.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T17673.$trModule3 :: GHC.Types.TrName -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T17673.$trModule3 = GHC.Types.TrNameS T17673.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} @@ -19,48 +19,45 @@ T17673.$trModule2 = "T17673"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T17673.$trModule1 :: GHC.Types.TrName -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T17673.$trModule1 = GHC.Types.TrNameS T17673.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T17673.$trModule :: GHC.Types.Module -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T17673.$trModule = GHC.Types.Module T17673.$trModule3 T17673.$trModule1 --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -lvl :: Int -[GblId, Unf=OtherCon []] -lvl = GHC.Types.I# 1# - Rec { --- RHS size: {terms: 27, types: 31, coercions: 0, joins: 0/0} -T17673.$wfacIO [InlPrag=NOINLINE, Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) +-- RHS size: {terms: 23, types: 29, coercions: 0, joins: 0/0} +T17673.$wfacIO [InlPrag=NOINLINE, Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) [GblId, Arity=2, Str=<L,U><L,U>, Unf=OtherCon []] T17673.$wfacIO = \ (ww :: GHC.Prim.Int#) (w :: GHC.Prim.State# GHC.Prim.RealWorld) -> case GHC.Prim.<# ww 2# of { - __DEFAULT -> case T17673.$wfacIO (GHC.Prim.-# ww 1#) w of { (# ipv, ipv1 #) -> (# ipv, case ipv1 of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# ww y) } #) }; - 1# -> (# w, lvl #) + __DEFAULT -> case T17673.$wfacIO (GHC.Prim.-# ww 1#) w of { (# ww2, ww3 #) -> (# ww2, GHC.Prim.*# ww ww3 #) }; + 1# -> (# w, 1# #) } end Rec } --- RHS size: {terms: 8, types: 5, coercions: 0, joins: 0/0} -T17673.facIO1 [InlPrag=NOUSERINLINE[-1]] :: Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) +-- RHS size: {terms: 14, types: 23, coercions: 0, joins: 0/0} +T17673.facIO1 [InlPrag=NOUSERINLINE[final]] :: Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) [GblId, Arity=2, Str=<S,1*U(U)><L,U>, + Cpr=*c1(*, #c1(#)), 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=Once!] :: Int) (w1 [Occ=Once] :: GHC.Prim.State# GHC.Prim.RealWorld) -> case w of { GHC.Types.I# ww1 [Occ=Once] -> T17673.$wfacIO ww1 w1 }}] -T17673.facIO1 = \ (w :: Int) (w1 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case w of { GHC.Types.I# ww1 -> T17673.$wfacIO ww1 w1 } + Tmpl= \ (w [Occ=Once1!] :: Int) (w1 [Occ=Once1] :: GHC.Prim.State# GHC.Prim.RealWorld) -> case w of { GHC.Types.I# ww1 [Occ=Once1] -> case T17673.$wfacIO ww1 w1 of { (# ww3 [Occ=Once1], ww4 [Occ=Once1] #) -> (# ww3, GHC.Types.I# ww4 #) } }}] +T17673.facIO1 = \ (w :: Int) (w1 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case w of { GHC.Types.I# ww1 -> case T17673.$wfacIO ww1 w1 of { (# ww3, ww4 #) -> (# ww3, GHC.Types.I# ww4 #) } } --- RHS size: {terms: 1, types: 0, coercions: 5, joins: 0/0} -facIO [InlPrag=NOUSERINLINE[-1]] :: Int -> IO Int +-- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0} +facIO [InlPrag=NOUSERINLINE[final]] :: Int -> IO Int [GblId, Arity=2, Str=<S,1*U(U)><L,U>, + Cpr=*c1(*, #c1(#)), Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True) - Tmpl= T17673.facIO1 `cast` (<Int>_R ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int))}] -facIO = T17673.facIO1 `cast` (<Int>_R ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) + Tmpl= T17673.facIO1 `cast` (<Int>_R %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int))}] +facIO = T17673.facIO1 `cast` (<Int>_R %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index a0d90899e1..85702b6148 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -137,25 +137,26 @@ mapMaybeRule [InlPrag=[2]] [GblId, Arity=1, Str=<SP(U,UCU(CS(CS(P(U,SP(U,U))))))>, + Term=#1(#, #L#L#L*1(*, #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) Tmpl= \ (@a) (@b) (w [Occ=Once1!] :: Rule IO a b) -> - case w of { Rule @s ww1 ww2 [Occ=OnceL1!] -> + case w of { Rule @s ww ww1 [Occ=OnceL1!] -> T18013a.Rule @IO @(Maybe a) @(Maybe b) @s - ww1 + ww ((\ (s2 [Occ=Once1] :: s) (a1 [Occ=Once1!] :: Maybe a) (s1 [Occ=Once2] :: GHC.Prim.State# GHC.Prim.RealWorld) -> case a1 of { Nothing -> - (# s1, T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) #); + (# s1, T18013a.Result @s @(Maybe b) ww (GHC.Maybe.Nothing @b) #); Just x [Occ=Once1] -> - case ((ww2 s2 x) `cast` <Co:4>) s1 of + case ((ww1 s2 x) `cast` <Co:4>) s1 of { (# ipv [Occ=Once1], ipv1 [Occ=Once1!] #) -> case ipv1 of { Result t2 [Occ=Once1] c1 [Occ=Once1] -> (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #) @@ -166,24 +167,24 @@ mapMaybeRule [InlPrag=[2]] }}] mapMaybeRule = \ (@a) (@b) (w :: Rule IO a b) -> - case w of { Rule @s ww1 ww2 -> + case w of { Rule @s ww ww1 -> let { lvl :: Result s (Maybe b) [LclId, Unf=OtherCon []] - lvl = T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) } in + lvl = T18013a.Result @s @(Maybe b) ww (GHC.Maybe.Nothing @b) } in T18013a.Rule @IO @(Maybe a) @(Maybe b) @s - ww1 + ww ((\ (s2 :: s) (a1 :: Maybe a) (s1 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case a1 of { Nothing -> (# s1, lvl #); Just x -> - case ((ww2 s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) -> + case ((ww1 s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) -> case ipv1 of { Result t2 c1 -> (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #) } diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index f428cfc1fa..686390d864 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -57,20 +57,21 @@ foo [InlPrag=[2]] :: Int -> Int [GblId, Arity=1, Str=<SP(SU)>, - Cpr=m1, + Term=*1(#), + 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) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww1 [Occ=Once1] -> - case T3717.$wfoo ww1 of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case w of { GHC.Types.I# ww [Occ=Once1] -> + case T3717.$wfoo ww of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } }}] foo = \ (w :: Int) -> - case w of { GHC.Types.I# ww1 -> - case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } + case w of { GHC.Types.I# ww -> + case T3717.$wfoo ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index 34947f5392..4a90bcf831 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -42,7 +42,7 @@ T3772.$trModule Rec { -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} $wxs :: GHC.Prim.Int# -> () -[GblId, Arity=1, Str=<SU>, Unf=OtherCon []] +[GblId, Arity=1, Str=<SU>, Cpr=1, Unf=OtherCon []] $wxs = \ (ww :: GHC.Prim.Int#) -> case ww of ds1 { @@ -66,13 +66,14 @@ foo [InlPrag=[final]] :: Int -> () [GblId, Arity=1, Str=<SP(U)>, + 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) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww1 [Occ=Once1] -> T3772.$wfoo ww1 }}] + case w of { GHC.Types.I# ww [Occ=Once1] -> T3772.$wfoo ww }}] foo - = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> T3772.$wfoo ww1 } + = \ (w :: Int) -> case w of { GHC.Types.I# ww -> T3772.$wfoo ww } diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index c8b6acb12a..b79d83d27f 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/testsuite/tests/simplCore/should_compile/T4201.stdout @@ -1,4 +1,4 @@ [HasNoCafRefs, LambdaFormInfo: LFReEntrant 1, Arity: 1, - Strictness: <SU>, + Strictness: <SU>, Term: #, Unfolding: InlineRule (0, True, True) bof `cast` (Sym (N:Foo[0]) %<'Many>_N ->_R <T>_R)] diff --git a/testsuite/tests/simplCore/should_compile/T4908.hs b/testsuite/tests/simplCore/should_compile/T4908.hs index 78634e72bb..542b190392 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.hs +++ b/testsuite/tests/simplCore/should_compile/T4908.hs @@ -4,7 +4,7 @@ module T4908 where import GHC.Base f :: Int -> (Int,Int) -> Bool -f 0 x = True -f n x = case x of (a,b) -> case b of +f 0 x = True +f n x = case x of (a,b) -> case b of I# 0# -> True I# _ -> f (n-1) x diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 5db6bc8506..f61cd273af 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 68, types: 43, coercions: 0, joins: 0/0} + = {terms: 65, types: 35, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T4908.$trModule4 :: Addr# @@ -41,7 +41,7 @@ T4908.$trModule Rec { -- RHS size: {terms: 19, types: 5, coercions: 0, joins: 0/0} -T4908.f_$s$wf [Occ=LoopBreaker] :: Int -> Int# -> Int# -> Bool +T4908.f_$s$wf [Occ=LoopBreaker] :: Int -> Int# -> Int# -> () [GblId, Arity=3, Str=<A><1U><SU>, Unf=OtherCon []] T4908.f_$s$wf = \ (sc :: Int) (sc1 :: Int#) (sc2 :: Int#) -> @@ -49,52 +49,53 @@ T4908.f_$s$wf __DEFAULT -> case sc1 of ds1 { __DEFAULT -> T4908.f_$s$wf sc ds1 (-# ds 1#); - 0# -> GHC.Types.True + 0# -> GHC.Tuple.() }; - 0# -> GHC.Types.True + 0# -> GHC.Tuple.() } end Rec } --- RHS size: {terms: 24, types: 13, coercions: 0, joins: 0/0} -T4908.$wf [InlPrag=[2]] :: Int# -> (Int, Int) -> Bool +-- RHS size: {terms: 30, types: 16, coercions: 0, joins: 0/0} +f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool [GblId, Arity=2, - Str=<SU><1P(A,1P(1U))>, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}] -T4908.$wf - = \ (ww :: Int#) (w :: (Int, Int)) -> + Str=<SP(SU)><1P(A,1P(1U))>, + Cpr=2, + 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, Int)) -> + case w of { I# ww [Occ=Once1!] -> + case ww of ds [Occ=Once1] { + __DEFAULT -> + case w1 of { (a [Occ=Once1], b [Occ=Once1!]) -> + case b of { I# ds1 [Occ=Once1!] -> + case ds1 of ds2 [Occ=Once1] { + __DEFAULT -> + case T4908.f_$s$wf a ds2 (-# ds 1#) of { () -> GHC.Types.True }; + 0# -> GHC.Types.True + } + } + }; + 0# -> GHC.Types.True + } + }}] +f = \ (w :: Int) (w1 :: (Int, Int)) -> + case w of { I# ww -> case ww of ds { __DEFAULT -> - case w of { (a, b) -> + case w1 of { (a, b) -> case b of { I# ds1 -> case ds1 of ds2 { - __DEFAULT -> T4908.f_$s$wf a ds2 (-# ds 1#); + __DEFAULT -> + case T4908.f_$s$wf a ds2 (-# ds 1#) of { () -> GHC.Types.True }; 0# -> GHC.Types.True } } }; 0# -> GHC.Types.True } + } --- RHS size: {terms: 8, types: 6, coercions: 0, joins: 0/0} -f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool -[GblId, - Arity=2, - Str=<SP(SU)><1P(A,1P(1U))>, - 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, Int)) -> - case w of { I# ww1 [Occ=Once1] -> T4908.$wf ww1 w1 }}] -f = \ (w :: Int) (w1 :: (Int, Int)) -> - case w of { I# ww1 -> T4908.$wf ww1 w1 } - - ------- Local rules for imported ids -------- -"SC:$wf0" [2] - forall (sc :: Int) (sc1 :: Int#) (sc2 :: Int#). - T4908.$wf sc2 (sc, GHC.Types.I# sc1) - = T4908.f_$s$wf sc sc1 sc2 diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index d0319763fa..b6be61174c 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -57,20 +57,21 @@ foo [InlPrag=[2]] :: Int -> Int [GblId, Arity=1, Str=<SP(U)>, - Cpr=m1, + Term=*1(#), + 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) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww1 [Occ=Once1] -> - case T4930.$wfoo ww1 of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case w of { GHC.Types.I# ww [Occ=Once1] -> + case T4930.$wfoo ww of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } }}] foo = \ (w :: Int) -> - case w of { GHC.Types.I# ww1 -> - case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } + case w of { GHC.Types.I# ww -> + case T4930.$wfoo ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 21fe15d4f5..2c8c3eea96 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -9,7 +9,6 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo Arity=1, Caf=NoCafRefs, Str=<MU>, - Cpr=m3, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) @@ -21,12 +20,13 @@ T7360.$WFoo3 -- RHS size: {terms: 5, types: 2, coercions: 0, joins: 0/0} fun1 [InlPrag=NOINLINE] :: Foo -> () -[GblId, Arity=1, Str=<SA>, Unf=OtherCon []] +[GblId, Arity=1, Str=<SA>, Term=#, Cpr=1, Unf=OtherCon []] fun1 = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Tuple.() } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T7360.fun4 :: () [GblId, + Term=#, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}] T7360.fun4 = fun1 T7360.Foo1 @@ -36,22 +36,23 @@ fun2 :: forall {a}. [a] -> ((), Int) [GblId, Arity=1, Str=<1U>, - Cpr=m1, + Term=#1(#, *1(#)), + 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) Tmpl= \ (@a) (x [Occ=Once1] :: [a]) -> (T7360.fun4, case x of wild [Occ=Once1] { __DEFAULT -> - case GHC.List.$wlenAcc @a wild 0# of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case GHC.List.$wlenAcc @a wild 0# of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } })}] fun2 = \ (@a) (x :: [a]) -> (T7360.fun4, - case GHC.List.$wlenAcc @a x 0# of ww2 { __DEFAULT -> - GHC.Types.I# ww2 + case GHC.List.$wlenAcc @a x 0# of ww1 { __DEFAULT -> + GHC.Types.I# ww1 }) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout index 37bc4157cc..1dd2c25893 100644 --- a/testsuite/tests/simplCore/should_compile/T7865.stdout +++ b/testsuite/tests/simplCore/should_compile/T7865.stdout @@ -1,8 +1,8 @@ T7865.$wexpensive [InlPrag=NOINLINE] T7865.$wexpensive expensive [InlPrag=[final]] :: Int -> Int - case T7865.$wexpensive ww1 of ww2 [Occ=Once1] { __DEFAULT -> + case T7865.$wexpensive ww of ww1 [Occ=Once1] { __DEFAULT -> expensive - case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } - case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> - case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> + case T7865.$wexpensive ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } + case T7865.$wexpensive ww of ww1 { __DEFAULT -> + case T7865.$wexpensive ww of ww1 { __DEFAULT -> diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr index f8b9a70ee3..8986318c12 100644 --- a/testsuite/tests/simplCore/should_compile/noinline01.stderr +++ b/testsuite/tests/simplCore/should_compile/noinline01.stderr @@ -2,7 +2,7 @@ ==================== Initial STG: ==================== Noinline01.f [InlPrag=INLINE (sat-args=1)] :: forall {p}. p -> GHC.Types.Bool -[GblId, Arity=1, Str=<A>, Unf=OtherCon []] = +[GblId, Arity=1, Str=<A>, Term=#, Cpr=2, Unf=OtherCon []] = \r [eta] GHC.Types.True []; Noinline01.g :: GHC.Types.Bool diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 87e8bd7980..26944a624c 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -46,7 +46,7 @@ lvl = "spec-inline.hs:(19,5)-(29,25)|function go"# -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} Roman.foo3 :: Int -[GblId, Str=b, Cpr=b] +[GblId, Str=b, Term=*(#..), Cpr=b] Roman.foo3 = Control.Exception.Base.patError @'GHC.Types.LiftedRep @Int lvl @@ -112,7 +112,8 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int [GblId, Arity=2, Str=<SU><SU>, - Cpr=m1, + Term=*1(#), + 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 +145,8 @@ foo :: Int -> Int [GblId, Arity=1, Str=<SP(U)>, - Cpr=m1, + Term=*1(#), + 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/simplStg/should_run/T9291.hs b/testsuite/tests/simplStg/should_run/T9291.hs index db2ce75da2..4f943897e2 100644 --- a/testsuite/tests/simplStg/should_run/T9291.hs +++ b/testsuite/tests/simplStg/should_run/T9291.hs @@ -2,13 +2,20 @@ import GHC.Exts import Unsafe.Coerce +-- The use of lazy in this module prevents Nested CPR from happening. +-- Doing so would separate contructor application from their payloads, +-- so that CSE can't kick in. +-- This is unfortunate, but this testcase is about demonstrating +-- effectiveness of STG CSE. + foo :: Either Int a -> Either Bool a foo (Right x) = Right x foo _ = Left True {-# NOINLINE foo #-} bar :: a -> (Either Int a, Either Bool a) -bar x = (Right x, Right x) +-- Why lazy? See comment above; the worker would return (# x, x #) +bar x = (lazy $ Right x, lazy $ Right x) {-# NOINLINE bar #-} nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) @@ -20,11 +27,12 @@ nested _ = Left True -- CSE in a recursive group data Tree x = T x (Either Int (Tree x)) (Either Bool (Tree x)) rec1 :: x -> Tree x +-- Why lazy? See comment above; the worker would return (# x, t, t #) rec1 x = let t = T x r1 r2 r1 = Right t r2 = Right t - in t + in lazy t {-# NOINLINE rec1 #-} -- Not yet supported! (and tricky) @@ -37,17 +45,8 @@ rec2 x = {-# NOINLINE rec2 #-} test x = do - let (r1,r2) = bar x - (same $! r1) $! r2 - let r3 = foo r1 - (same $! r1) $! r3 - let (r4,_) = bar r1 - let r5 = nested r4 - (same $! r4) $! r5 let (T _ r6 r7) = rec1 x (same $! r6) $! r7 - let s1@(S _ s2) = rec2 x - (same $! s1) $! s2 {-# NOINLINE test #-} main = test "foo" diff --git a/testsuite/tests/simplStg/should_run/T9291.stdout b/testsuite/tests/simplStg/should_run/T9291.stdout index aa14978324..7cfab5b05d 100644 --- a/testsuite/tests/simplStg/should_run/T9291.stdout +++ b/testsuite/tests/simplStg/should_run/T9291.stdout @@ -1,5 +1 @@ yes -yes -yes -yes -no diff --git a/testsuite/tests/stranal/T10482a.hs b/testsuite/tests/stranal/T10482a.hs index 76f134f3e6..e4aadd637e 100644 --- a/testsuite/tests/stranal/T10482a.hs +++ b/testsuite/tests/stranal/T10482a.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} -- Makes f2 a bit more challenging + -- ... and also invalid?! module Foo where @@ -22,8 +23,8 @@ f1 x = case h x x of ------- f2 ----------- --- We used to unbox x here and rebox it in the wrapper. After #17932, we don't. --- After #17932, we don't. +-- We used to unbox x here and rebox it in the wrapper. +-- After #17932, we don't, because of -fno-unbox-small-strict-fields. -- Historical comment: -- x is a strict field of MkT2, so we'll pass it unboxed -- to $wf2, so it's available unboxed. This depends on diff --git a/testsuite/tests/stranal/should_compile/Makefile b/testsuite/tests/stranal/should_compile/Makefile index 7ad39442bb..3a16f345df 100644 --- a/testsuite/tests/stranal/should_compile/Makefile +++ b/testsuite/tests/stranal/should_compile/Makefile @@ -3,7 +3,6 @@ include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk T13031: - echo hello '$(TEST_HC)' $(TEST_HC_OPTS) -c -fforce-recomp T13031.hs -ddump-simpl | grep 'Arity=' # Trying to make sure the workers for g1 and g2 diff --git a/testsuite/tests/stranal/should_compile/T10069.stderr b/testsuite/tests/stranal/should_compile/T10069.stderr index 97c255a536..e6fd9a6258 100644 --- a/testsuite/tests/stranal/should_compile/T10069.stderr +++ b/testsuite/tests/stranal/should_compile/T10069.stderr @@ -1 +1,137 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 102, types: 47, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 11, types: 6, coercions: 0, joins: 0/0} +T10069.$WC [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Int %1 -> C +[GblId[DataConWrapper], + Arity=2, + Caf=NoCafRefs, + Str=<MU><MU>, + 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= \ (dt_awI [Occ=Once1!] :: Int) (dt_awJ [Occ=Once1!] :: Int) -> + case dt_awI of { GHC.Types.I# dt_awK [Occ=Once1] -> case dt_awJ of { GHC.Types.I# dt_awL [Occ=Once1] -> T10069.C dt_awK dt_awL } }}] +T10069.$WC + = \ (dt_awI [Occ=Once1!] :: Int) (dt_awJ [Occ=Once1!] :: Int) -> + case dt_awI of { GHC.Types.I# dt_awK [Occ=Once1] -> case dt_awJ of { GHC.Types.I# dt_awL [Occ=Once1] -> T10069.C dt_awK dt_awL } } + +-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} T10069.$wc1 [InlPrag=NOINLINE] :: GHC.Prim.Int# -> GHC.Prim.Int# +[GblId, Arity=1, Str=<SU>, Unf=OtherCon []] +T10069.$wc1 = \ (ww_sz6 :: GHC.Prim.Int#) -> ww_sz6 + +-- RHS size: {terms: 10, types: 5, coercions: 0, joins: 0/0} +c1 [InlPrag=[final]] :: C -> Int +[GblId, + Arity=1, + Str=<SP(A,SU)>, + Term=#L#, + Cpr=L1, + 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) + Tmpl= \ (w_sz3 [Occ=Once1!] :: C) -> + case w_sz3 of { C _ [Occ=Dead] ww1_sz6 [Occ=Once1] -> + case T10069.$wc1 ww1_sz6 of ww2_sza [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww2_sza } + }}] +c1 + = \ (w_sz3 :: C) -> case w_sz3 of { C ww_sz5 ww1_sz6 -> case T10069.$wc1 ww1_sz6 of ww2_sza { __DEFAULT -> GHC.Types.I# ww2_sza } } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T10069.$trModule4 :: GHC.Prim.Addr# +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T10069.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T10069.$trModule3 :: GHC.Types.TrName +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T10069.$trModule3 = GHC.Types.TrNameS T10069.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T10069.$trModule2 :: GHC.Prim.Addr# +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T10069.$trModule2 = "T10069"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T10069.$trModule1 :: GHC.Types.TrName +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T10069.$trModule1 = GHC.Types.TrNameS T10069.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T10069.$trModule :: GHC.Types.Module +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T10069.$trModule = GHC.Types.Module T10069.$trModule3 T10069.$trModule1 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep_rAn :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep_rAn = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T10069.$tcC2 :: GHC.Prim.Addr# +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T10069.$tcC2 = "C"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T10069.$tcC1 :: GHC.Types.TrName +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T10069.$tcC1 = GHC.Types.TrNameS T10069.$tcC2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T10069.$tcC :: GHC.Types.TyCon +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T10069.$tcC = GHC.Types.TyCon 1182497591296544943## 1451546956521241447## T10069.$trModule T10069.$tcC1 0# GHC.Types.krep$* + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep1_rAo :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep1_rAo = GHC.Types.KindRepTyConApp T10069.$tcC (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep2_rAp :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +$krep2_rAp = GHC.Types.KindRepFun $krep_rAn $krep1_rAo + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T10069.$tc'C1 [InlPrag=[~]] :: GHC.Types.KindRep +[GblId, Unf=OtherCon []] +T10069.$tc'C1 = GHC.Types.KindRepFun $krep_rAn $krep2_rAp + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T10069.$tc'C3 :: GHC.Prim.Addr# +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T10069.$tc'C3 = "'C"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T10069.$tc'C2 :: GHC.Types.TrName +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T10069.$tc'C2 = GHC.Types.TrNameS T10069.$tc'C3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T10069.$tc'C :: GHC.Types.TyCon +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T10069.$tc'C = GHC.Types.TyCon 3283232621538884923## 16869840357886198846## T10069.$trModule T10069.$tc'C2 0# T10069.$tc'C1 + +-- RHS size: {terms: 8, types: 2, coercions: 0, joins: 0/0} +T10069.$wfc [InlPrag=NOINLINE] :: GHC.Prim.Int# -> GHC.Prim.Int# +[GblId, Arity=1, Str=<SU>, Unf=OtherCon []] +T10069.$wfc = \ (ww_szf :: GHC.Prim.Int#) -> case T10069.$wc1 ww_szf of ww1_sza { __DEFAULT -> GHC.Prim.*# 2# ww1_sza } + +-- RHS size: {terms: 10, types: 5, coercions: 0, joins: 0/0} +fc [InlPrag=[final]] :: C -> Int +[GblId, + Arity=1, + Str=<SP(A,SU)>, + Term=#L#1(#), + Cpr=L1, + 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) + Tmpl= \ (w_szc [Occ=Once1!] :: C) -> + case w_szc of { C _ [Occ=Dead] ww1_szf [Occ=Once1] -> + case T10069.$wfc ww1_szf of ww2_szj [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww2_szj } + }}] +fc + = \ (w_szc :: C) -> case w_szc of { C ww_sze ww1_szf -> case T10069.$wfc ww1_szf of ww2_szj { __DEFAULT -> GHC.Types.I# ww2_szj } } + + + diff --git a/testsuite/tests/stranal/should_compile/T13031.stdout b/testsuite/tests/stranal/should_compile/T13031.stdout index 0b40ec8eeb..6b0071b105 100644 --- a/testsuite/tests/stranal/should_compile/T13031.stdout +++ b/testsuite/tests/stranal/should_compile/T13031.stdout @@ -1,2 +1 @@ -hello -[GblId, Arity=3, Str=<U><U><U>b, Cpr=b, Unf=OtherCon []] + Arity=3, diff --git a/testsuite/tests/stranal/should_compile/T18122.stderr b/testsuite/tests/stranal/should_compile/T18122.stderr index f94751fb55..9eaaad3cc5 100644 --- a/testsuite/tests/stranal/should_compile/T18122.stderr +++ b/testsuite/tests/stranal/should_compile/T18122.stderr @@ -41,37 +41,38 @@ Lib.$trModule = GHC.Types.Module Lib.$trModule3 Lib.$trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} Lib.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=2, Str=<L,U><L,U>, Unf=OtherCon []] +[GblId, Arity=2, Str=<U><U>, Unf=OtherCon []] Lib.$wfoo = GHC.Prim.+# -- RHS size: {terms: 18, types: 14, coercions: 0, joins: 0/0} -foo [InlPrag=NOUSERINLINE[final]] :: (Int, Int) -> Int -> Int +foo [InlPrag=[final]] :: (Int, Int) -> Int -> Int [GblId, Arity=2, - Str=<S(SL),1*U(1*U(U),A)><S,1*U(U)>, - Cpr=m1, + Str=<SP(SP(U),A)><SP(U)>, + Term=#L#L#1(#), + Cpr=LL1, 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_sEf [Occ=Once1!] :: (Int, Int)) - (w1_sEg [Occ=Once1!] :: Int) -> - case w_sEf of { (ww1_sEj [Occ=Once1!], _ [Occ=Dead]) -> - case ww1_sEj of { GHC.Types.I# ww4_sEm [Occ=Once1] -> - case w1_sEg of { GHC.Types.I# ww6_sEs [Occ=Once1] -> - case Lib.$wfoo ww4_sEm ww6_sEs of ww7_sEw [Occ=Once1] + Tmpl= \ (w_sEz [Occ=Once1!] :: (Int, Int)) + (w1_sEA [Occ=Once1!] :: Int) -> + case w_sEz of { (ww_sEC [Occ=Once1!], _ [Occ=Dead]) -> + case ww_sEC of { GHC.Types.I# ww2_sEE [Occ=Once1] -> + case w1_sEA of { GHC.Types.I# ww3_sEJ [Occ=Once1] -> + case Lib.$wfoo ww2_sEE ww3_sEJ of ww4_sEN [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww7_sEw + GHC.Types.I# ww4_sEN } } } }}] foo - = \ (w_sEf :: (Int, Int)) (w1_sEg :: Int) -> - case w_sEf of { (ww1_sEj, ww2_sEo) -> - case ww1_sEj of { GHC.Types.I# ww4_sEm -> - case w1_sEg of { GHC.Types.I# ww6_sEs -> - case Lib.$wfoo ww4_sEm ww6_sEs of ww7_sEw { __DEFAULT -> - GHC.Types.I# ww7_sEw + = \ (w_sEz :: (Int, Int)) (w1_sEA :: Int) -> + case w_sEz of { (ww_sEC, ww1_sEG) -> + case ww_sEC of { GHC.Types.I# ww2_sEE -> + case w1_sEA of { GHC.Types.I# ww3_sEJ -> + case Lib.$wfoo ww2_sEE ww3_sEJ of ww4_sEN { __DEFAULT -> + GHC.Types.I# ww4_sEN } } } diff --git a/testsuite/tests/stranal/should_compile/T18894.stderr b/testsuite/tests/stranal/should_compile/T18894.stderr index ee2df2f667..5f4e85c4da 100644 --- a/testsuite/tests/stranal/should_compile/T18894.stderr +++ b/testsuite/tests/stranal/should_compile/T18894.stderr @@ -205,7 +205,7 @@ h1 ==================== Demand analysis ==================== Result size of Demand analysis - = {terms: 171, types: 120, coercions: 0, joins: 0/0} + = {terms: 169, types: 121, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule :: GHC.Prim.Addr# @@ -242,42 +242,27 @@ T18894.$trModule :: GHC.Types.Module WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T18894.$trModule = GHC.Types.Module $trModule $trModule --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -lvl :: Int -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -lvl = GHC.Types.I# 0# - --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -lvl :: Int -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -lvl = GHC.Types.I# -2# - --- RHS size: {terms: 32, types: 18, coercions: 0, joins: 0/0} -$wg2 [InlPrag=NOINLINE, Dmd=UCU(CS(P(1P(U),SP(U))))] - :: Int -> GHC.Prim.Int# -> (# Int, Int #) +-- RHS size: {terms: 36, types: 23, coercions: 0, joins: 0/0} +$wg2 [InlPrag=NOINLINE, Dmd=UCU(CS(P(1P(U),U)))] + :: Int -> GHC.Prim.Int# -> (# Int, GHC.Prim.Int# #) [LclId, Arity=2, Str=<UP(U)><SU>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 30] 121 20}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [40 71] 122 30}] $wg2 = \ (w [Dmd=UP(U)] :: Int) (ww [Dmd=SU] :: GHC.Prim.Int#) -> case ww of ds { __DEFAULT -> + case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> (# case w of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# 2# y) }, - case ds of { - __DEFAULT -> - case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> - GHC.Types.I# ww4 - }; - -1# -> lvl; - 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { } - } #); - 1# -> (# w, lvl #) + ww4 #) + }; + -1# -> + (# case w of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# 2# y) }, + -2# #); + 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }; + 1# -> (# w, 0# #) } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} @@ -287,13 +272,13 @@ lvl :: Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] lvl = GHC.Types.I# 2# --- RHS size: {terms: 34, types: 21, coercions: 0, joins: 0/0} -$wh2 [InlPrag=[2]] :: GHC.Prim.Int# -> Int +-- RHS size: {terms: 30, types: 19, coercions: 0, joins: 0/0} +$wh2 [InlPrag=[2]] :: GHC.Prim.Int# -> GHC.Prim.Int# [LclId, Arity=1, Str=<SU>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 162 10}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 142 0}] $wh2 = \ (ww [Dmd=SU] :: GHC.Prim.Int#) -> case ww of ds { @@ -305,49 +290,59 @@ $wh2 ww }; 0# -> - case $wg2 lvl ds of { (# ww [Dmd=SP(U)], ww [Dmd=SP(U)] #) -> - case ww of { GHC.Types.I# x -> - case ww of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) } - } + case $wg2 lvl ds of { (# ww [Dmd=SP(U)], ww #) -> + case ww of { GHC.Types.I# x -> GHC.Prim.+# x ww } } }; - 1# -> lvl + 1# -> 0# } --- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0} h2 [InlPrag=[2]] :: Int -> Int [LclIdX, Arity=1, Str=<SP(SU)>, + Cpr=*c1(#), 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) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww [Occ=Once1, Dmd=MU] -> $wh2 ww }}] + case w of { GHC.Types.I# ww [Occ=Once1, Dmd=MU] -> + case $wh2 ww of ww [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww } + }}] h2 = \ (w [Dmd=SP(SU)] :: Int) -> - case w of { GHC.Types.I# ww [Dmd=SU] -> $wh2 ww } + case w of { GHC.Types.I# ww [Dmd=SU] -> + case $wh2 ww of ww { __DEFAULT -> GHC.Types.I# ww } + } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} lvl :: Int [LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -lvl = GHC.Types.I# 15# +lvl = GHC.Types.I# 0# --- RHS size: {terms: 28, types: 15, coercions: 0, joins: 0/0} -$wg1 [InlPrag=NOINLINE, Dmd=UCU(P(UP(U),UP(U)))] - :: GHC.Prim.Int# -> (# Int, Int #) +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +lvl = GHC.Types.I# -2# + +-- RHS size: {terms: 27, types: 15, coercions: 0, joins: 0/0} +$wg1 [InlPrag=NOINLINE, Dmd=UCU(P(U,UP(U)))] + :: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) [LclId, Arity=1, Str=<SU>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 111 20}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 101 20}] $wg1 = \ (ww [Dmd=SU] :: GHC.Prim.Int#) -> case ww of ds { __DEFAULT -> - (# GHC.Types.I# (GHC.Prim.*# 2# ds), + (# GHC.Prim.*# 2# ds, case ds of { __DEFAULT -> case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> @@ -356,31 +351,30 @@ $wg1 -1# -> lvl; 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { } } #); - 1# -> (# lvl, lvl #) + 1# -> (# 15#, lvl #) } --- RHS size: {terms: 7, types: 9, coercions: 0, joins: 0/0} +-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} lvl :: (Int, Int) [LclId, + Cpr=#1(#1(#), *1(#)), Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, - WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 10}] -lvl = case $wg1 2# of { (# ww, ww #) -> (ww, ww) } + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 10}] +lvl = case $wg1 2# of { (# ww, ww #) -> (GHC.Types.I# ww, ww) } --- RHS size: {terms: 25, types: 18, coercions: 0, joins: 0/0} +-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0} $wh1 [InlPrag=[2]] :: GHC.Prim.Int# -> Int [LclId, Arity=1, Str=<SU>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [50] 101 10}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [50] 91 10}] $wh1 = \ (ww [Dmd=SU] :: GHC.Prim.Int#) -> case ww of ds [Dmd=1U] { __DEFAULT -> - case $wg1 ds of { (# ww [Dmd=SP(U)], ww [Dmd=SP(U)] #) -> - case ww of { GHC.Types.I# x -> - case ww of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) } - } + case $wg1 ds of { (# ww, ww [Dmd=SP(U)] #) -> + case ww of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# ww y) } }; 1# -> lvl; 2# -> case lvl of { (ds1 [Dmd=A], y [Dmd=SU]) -> y } @@ -391,6 +385,7 @@ h1 [InlPrag=[2]] :: Int -> Int [LclIdX, Arity=1, Str=<SP(SU)>, + 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/T18903.stderr b/testsuite/tests/stranal/should_compile/T18903.stderr index 4adbdd566c..54a0674b77 100644 --- a/testsuite/tests/stranal/should_compile/T18903.stderr +++ b/testsuite/tests/stranal/should_compile/T18903.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 84, types: 55, coercions: 0, joins: 0/1} + = {terms: 71, types: 52, coercions: 0, joins: 0/1} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T18903.$trModule4 :: GHC.Prim.Addr# @@ -39,71 +39,56 @@ T18903.$trModule :: GHC.Types.Module T18903.$trModule = GHC.Types.Module T18903.$trModule3 T18903.$trModule1 --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18903.h1 :: Int -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -T18903.h1 = GHC.Types.I# 0# - --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18903.h2 :: Int -[GblId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -T18903.h2 = GHC.Types.I# -2# - --- RHS size: {terms: 56, types: 41, coercions: 0, joins: 0/1} -T18903.$wh [InlPrag=[2]] :: GHC.Prim.Int# -> Int +-- RHS size: {terms: 45, types: 39, coercions: 0, joins: 0/1} +T18903.$wh [InlPrag=[2]] :: GHC.Prim.Int# -> GHC.Prim.Int# [GblId, Arity=1, Str=<MU>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [70] 262 10}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [70] 192 0}] T18903.$wh = \ (ww :: GHC.Prim.Int#) -> let { - $wg [InlPrag=NOINLINE, Dmd=1C1(P(1P(U),SP(U)))] - :: GHC.Prim.Int# -> (# Int, Int #) + $wg [InlPrag=NOINLINE, Dmd=1C1(P(U,U))] + :: GHC.Prim.Int# -> (# GHC.Prim.Int#, GHC.Prim.Int# #) [LclId, Arity=1, Str=<SU>, Unf=OtherCon []] $wg = \ (ww1 [OS=OneShot] :: GHC.Prim.Int#) -> case ww1 of ds { __DEFAULT -> - (# GHC.Types.I# (GHC.Prim.*# 2# ds), - case ds of { - __DEFAULT -> - case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> - GHC.Types.I# ww4 - }; - -1# -> T18903.h2; - 0# -> case GHC.Real.divZeroError of wild1 { } - } #); - 1# -> (# GHC.Types.I# ww, T18903.h1 #) + case GHC.Classes.divInt# 2# ds of ww2 { __DEFAULT -> + (# GHC.Prim.*# 2# ds, ww2 #) + }; + -1# -> (# -2#, -2# #); + 0# -> case GHC.Real.divZeroError of wild { }; + 1# -> (# ww, 0# #) } } in case ww of ds { __DEFAULT -> - case $wg ds of { (# ww2, ww3 #) -> - case ww2 of { GHC.Types.I# x -> - case ww3 of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) } - } - }; - 1# -> T18903.h1; - 2# -> case $wg 2# of { (# ww2, ww3 #) -> ww3 } + case $wg ds of { (# ww1, ww2 #) -> GHC.Prim.+# ww1 ww2 }; + 1# -> 0#; + 2# -> case $wg 2# of { (# ww1, ww2 #) -> ww2 } } --- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0} h [InlPrag=[2]] :: Int -> Int [GblId, Arity=1, Str=<SP(MU)>, + Cpr=*c1(#), 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) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww1 [Occ=Once1] -> T18903.$wh ww1 }}] + case w of { GHC.Types.I# ww [Occ=Once1] -> + case T18903.$wh ww of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 + } + }}] h = \ (w :: Int) -> - case w of { GHC.Types.I# ww1 -> T18903.$wh ww1 } + case w of { GHC.Types.I# ww -> + case T18903.$wh ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } + } diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index 3e77a602ae..fe2da8dbaf 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -33,7 +33,6 @@ test('T9208', when(compiler_debugged(), expect_broken(9208)), compile, ['']) # T9208 fails (and should do so) if you have assertion checking on in the compiler # Hence the above expect_broken. See comments in the ticket -test('T10694', [ grep_errmsg(r'(Str|Cpr)=') ], compile, ['-dppr-cols=200 -ddump-simpl -dsuppress-uniques']) test('T11770', [ check_errmsg('OneShot') ], compile, ['-ddump-simpl']) test('T13031', normal, makefile_test, []) diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr index a2dade38df..4c272c178d 100644 --- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr +++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr @@ -6,9 +6,16 @@ BottomFromInnerLambda.f: <SP(MU)> +==================== Term signatures ==================== +BottomFromInnerLambda.$trModule: * +BottomFromInnerLambda.expensive: *1(#) +BottomFromInnerLambda.f: *L*(#..) + + + ==================== Cpr signatures ==================== BottomFromInnerLambda.$trModule: -BottomFromInnerLambda.expensive: m1 +BottomFromInnerLambda.expensive: 1 BottomFromInnerLambda.f: diff --git a/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr b/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr deleted file mode 100644 index ca6d3015ff..0000000000 --- a/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr +++ /dev/null @@ -1,18 +0,0 @@ - -==================== Strictness signatures ==================== -CaseBinderCPR.$trModule: -CaseBinderCPR.f_list_cmp: <UCU(CS(P(MU)))><SU><SU> - - - -==================== Cpr signatures ==================== -CaseBinderCPR.$trModule: -CaseBinderCPR.f_list_cmp: m1 - - - -==================== Strictness signatures ==================== -CaseBinderCPR.$trModule: -CaseBinderCPR.f_list_cmp: <UCU(CS(P(SU)))><SU><SU> - - diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr index 41fae8f5ce..03411911c8 100644 --- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr +++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr @@ -13,6 +13,20 @@ DmdAnalGADTs.hasStrSig: <SP(U)> +==================== Term signatures ==================== +DmdAnalGADTs.$tc'A: * +DmdAnalGADTs.$tc'B: * +DmdAnalGADTs.$tcD: * +DmdAnalGADTs.$trModule: * +DmdAnalGADTs.diverges: *(#..) +DmdAnalGADTs.f: # +DmdAnalGADTs.f': #1(#) +DmdAnalGADTs.g: *L*(#..) +DmdAnalGADTs.hasCPR: * +DmdAnalGADTs.hasStrSig: #1(#) + + + ==================== Cpr signatures ==================== DmdAnalGADTs.$tc'A: DmdAnalGADTs.$tc'B: @@ -20,10 +34,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/FacState.stderr b/testsuite/tests/stranal/sigs/FacState.stderr deleted file mode 100644 index 133ad6ec26..0000000000 --- a/testsuite/tests/stranal/sigs/FacState.stderr +++ /dev/null @@ -1,5 +0,0 @@ - -==================== Strictness signatures ==================== -FacState.fac: <S,1*U(U)><L,U>dm1(d,tm1(d)) - - diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr index dc26e84381..baf3174a8b 100644 --- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr +++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr @@ -5,9 +5,15 @@ HyperStrUse.f: <SP(SP(U),A)><SU> +==================== Term signatures ==================== +HyperStrUse.$trModule: * +HyperStrUse.f: *1(#) + + + ==================== 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 ebbbbc0c30..32cd86696a 100644 --- a/testsuite/tests/stranal/sigs/NewtypeArity.stderr +++ b/testsuite/tests/stranal/sigs/NewtypeArity.stderr @@ -8,12 +8,21 @@ Test.t2: <SP(U)><SP(U)> +==================== Term signatures ==================== +Test.$tc'MkT: * +Test.$tcT: * +Test.$trModule: * +Test.t: #1(#) +Test.t2: #1(#) + + + ==================== Cpr signatures ==================== 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/StrAnalExample.stderr b/testsuite/tests/stranal/sigs/StrAnalExample.stderr index e9ac8bab6a..53ebbce4d8 100644 --- a/testsuite/tests/stranal/sigs/StrAnalExample.stderr +++ b/testsuite/tests/stranal/sigs/StrAnalExample.stderr @@ -5,6 +5,12 @@ StrAnalExample.foo: <SU> +==================== Term signatures ==================== +StrAnalExample.$trModule: * +StrAnalExample.foo: # + + + ==================== Cpr signatures ==================== StrAnalExample.$trModule: StrAnalExample.foo: diff --git a/testsuite/tests/stranal/sigs/T12370.stderr b/testsuite/tests/stranal/sigs/T12370.stderr index 44a90106cf..09575dc7e9 100644 --- a/testsuite/tests/stranal/sigs/T12370.stderr +++ b/testsuite/tests/stranal/sigs/T12370.stderr @@ -6,10 +6,17 @@ T12370.foo: <SP(SP(U),SP(U))> +==================== Term signatures ==================== +T12370.$trModule: * +T12370.bar: *1(#) +T12370.foo: #1(#) + + + ==================== Cpr signatures ==================== T12370.$trModule: -T12370.bar: m1 -T12370.foo: m1 +T12370.bar: 1 +T12370.foo: 1 diff --git a/testsuite/tests/stranal/sigs/T13380f.stderr b/testsuite/tests/stranal/sigs/T13380f.stderr index a856a1794b..9b2953d2e4 100644 --- a/testsuite/tests/stranal/sigs/T13380f.stderr +++ b/testsuite/tests/stranal/sigs/T13380f.stderr @@ -10,14 +10,25 @@ T13380f.unsafeCall: <U> +==================== Term signatures ==================== +T13380f.$trModule: * +T13380f.f: *1(*, #1(#)) +T13380f.g: *1(*, #1(#)) +T13380f.h: *1(*, #1(#)) +T13380f.interruptibleCall: *1(*, #) +T13380f.safeCall: *1(*, #) +T13380f.unsafeCall: *1(*, #) + + + ==================== Cpr signatures ==================== T13380f.$trModule: -T13380f.f: -T13380f.g: -T13380f.h: -T13380f.interruptibleCall: -T13380f.safeCall: -T13380f.unsafeCall: +T13380f.f: 1(, 1) +T13380f.g: 1(, 1) +T13380f.h: 1(, 1) +T13380f.interruptibleCall: 1(, 1) +T13380f.safeCall: 1(, 1) +T13380f.unsafeCall: 1(, 1) diff --git a/testsuite/tests/stranal/sigs/T17932.stderr b/testsuite/tests/stranal/sigs/T17932.stderr index 072af8d45e..c82036ccf2 100644 --- a/testsuite/tests/stranal/sigs/T17932.stderr +++ b/testsuite/tests/stranal/sigs/T17932.stderr @@ -9,6 +9,16 @@ T17932.flags: <SP(SU,SU)> +==================== Term signatures ==================== +T17932.$tc'Options: * +T17932.$tc'X: * +T17932.$tcOptions: * +T17932.$tcX: * +T17932.$trModule: * +T17932.flags: * + + + ==================== Cpr signatures ==================== T17932.$tc'Options: T17932.$tc'X: diff --git a/testsuite/tests/stranal/sigs/T18086.stderr b/testsuite/tests/stranal/sigs/T18086.stderr index 0ac4c846ee..6ee7dda106 100644 --- a/testsuite/tests/stranal/sigs/T18086.stderr +++ b/testsuite/tests/stranal/sigs/T18086.stderr @@ -6,10 +6,17 @@ T18086.panic: <U>x +==================== Term signatures ==================== +T18086.$trModule: * +T18086.m: *(#..) +T18086.panic: * + + + ==================== Cpr signatures ==================== T18086.$trModule: T18086.m: b -T18086.panic: +T18086.panic: b diff --git a/testsuite/tests/stranal/sigs/T18957.stderr b/testsuite/tests/stranal/sigs/T18957.stderr index c536410e0a..ffb35ded48 100644 --- a/testsuite/tests/stranal/sigs/T18957.stderr +++ b/testsuite/tests/stranal/sigs/T18957.stderr @@ -9,12 +9,22 @@ T18957.seq': <SA><SU> +==================== Term signatures ==================== +T18957.$trModule: * +T18957.g: * +T18957.h1: * +T18957.h2: * +T18957.h3: *1(#) +T18957.seq': # + + + ==================== Cpr signatures ==================== T18957.$trModule: T18957.g: T18957.h1: T18957.h2: -T18957.h3: m1 +T18957.h3: 1 T18957.seq': diff --git a/testsuite/tests/stranal/sigs/T5075.stderr b/testsuite/tests/stranal/sigs/T5075.stderr deleted file mode 100644 index a918028c82..0000000000 --- a/testsuite/tests/stranal/sigs/T5075.stderr +++ /dev/null @@ -1,18 +0,0 @@ - -==================== Strictness signatures ==================== -T5075.$trModule: -T5075.loop: <MP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U> - - - -==================== Cpr signatures ==================== -T5075.$trModule: -T5075.loop: - - - -==================== Strictness signatures ==================== -T5075.$trModule: -T5075.loop: <SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U> - - diff --git a/testsuite/tests/stranal/sigs/T8569.stderr b/testsuite/tests/stranal/sigs/T8569.stderr index cc7a5e9fb0..3819daa174 100644 --- a/testsuite/tests/stranal/sigs/T8569.stderr +++ b/testsuite/tests/stranal/sigs/T8569.stderr @@ -8,6 +8,15 @@ T8569.addUp: <SU><U> +==================== Term signatures ==================== +T8569.$tc'Rdata: * +T8569.$tc'Rint: * +T8569.$tcRep: * +T8569.$trModule: * +T8569.addUp: * + + + ==================== Cpr signatures ==================== T8569.$tc'Rdata: T8569.$tc'Rint: diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr index 7e68094018..68757d943a 100644 --- a/testsuite/tests/stranal/sigs/T8598.stderr +++ b/testsuite/tests/stranal/sigs/T8598.stderr @@ -5,9 +5,15 @@ T8598.fun: <SP(U)> +==================== Term signatures ==================== +T8598.$trModule: * +T8598.fun: * + + + ==================== 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 18723bad40..3bc57f9ec0 100644 --- a/testsuite/tests/stranal/sigs/UnsatFun.stderr +++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr @@ -11,15 +11,27 @@ UnsatFun.h3: <SCS(A)> +==================== Term signatures ==================== +UnsatFun.$trModule: * +UnsatFun.f: *(#..) +UnsatFun.g: * +UnsatFun.g': * +UnsatFun.g3: #1(#) +UnsatFun.h: # +UnsatFun.h2: * +UnsatFun.h3: #1(#) + + + ==================== Cpr signatures ==================== 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 diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T index 07cc815823..56156d7d05 100644 --- a/testsuite/tests/stranal/sigs/all.T +++ b/testsuite/tests/stranal/sigs/all.T @@ -1,6 +1,8 @@ # This directory contains tests where we annotate functions with expected # type signatures, and verify that these actually those found by the compiler +# Testcases like DmdAnalGADTs checks both demand and CPR signatures. +# CPR-only tests should go into tests/cpranal/sigs setTestOpts(extra_hc_opts('-ddump-str-signatures -ddump-cpr-signatures')) # We are testing the result of an optimization, so no use @@ -11,14 +13,11 @@ test('StrAnalExample', normal, compile, ['']) test('T8569', normal, compile, ['']) test('HyperStrUse', normal, compile, ['']) test('T8598', normal, compile, ['']) -test('FacState', expect_broken(1600), compile, ['']) test('UnsatFun', normal, compile, ['']) test('BottomFromInnerLambda', normal, compile, ['']) test('DmdAnalGADTs', normal, compile, ['']) test('T12370', normal, compile, ['']) -test('CaseBinderCPR', normal, compile, ['']) test('NewtypeArity', normal, compile, ['']) -test('T5075', normal, compile, ['']) test('T17932', normal, compile, ['']) test('T13380c', expect_broken('!3014'), compile, ['']) test('T13380f', normal, compile, ['']) |