[Git][ghc/ghc][wip/T18894] 2 commits: DmdAnal: Annotate top-level function bindings with demands (#18894)
Sebastian Graf
gitlab at gitlab.haskell.org
Fri Nov 27 12:13:53 UTC 2020
Sebastian Graf pushed to branch wip/T18894 at Glasgow Haskell Compiler / GHC
Commits:
b853798a by Sebastian Graf at 2020-11-27T11:41:35+01:00
DmdAnal: Annotate top-level function bindings with demands (#18894)
It's useful to annotate a non-exported top-level function like `g` in
```hs
module Lib (h) where
g :: Int -> Int -> (Int,Int)
g m 1 = (m, 0)
g m n = (2 * m, 2 `div` n)
{-# NOINLINE g #-}
h :: Int -> Int
h 1 = 0
h m
| odd m = snd (g m 2)
| otherwise = uncurry (+) (g 2 m)
```
with its demand `UCU(CS(P(1P(U),SP(U))`, which tells us that whenever `g` was
called, the second component of the returned pair was evaluated strictly.
Since #18903 we do so for local functions, where we can see all calls.
For top-level functions, we can assume that all *exported* functions are
demanded according to `topDmd` and thus get sound demands for
non-exported top-level functions.
The demand on `g` is crucial information for Nested CPR, which may the
go on and unbox `g` for the second pair component. That is true even if
that pair component may diverge, as is the case for the call site `g 13
0`, which throws a div-by-zero exception.
We only track bindings of function type in order not to risk huge compile-time
regressions, see `isInterestingTopLevelFn`.
Fixes #18894.
- - - - -
3a7344fb by Sebastian Graf at 2020-11-27T13:03:07+01:00
Demand: Simplify `CU(U)` to `U` (#19005)
Both sub-demands encode the same information.
This is a trivial change and already affects a few regression tests
(e.g. `T5075`), so no separate regression test is necessary.
- - - - -
13 changed files:
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Info.hs
- testsuite/tests/arityanal/should_compile/Arity11.stderr
- testsuite/tests/arityanal/should_compile/Arity16.stderr
- + testsuite/tests/stranal/should_compile/T18894.hs
- + testsuite/tests/stranal/should_compile/T18894.stderr
- testsuite/tests/stranal/should_compile/all.T
- testsuite/tests/stranal/sigs/T5075.stderr
Changes:
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -525,12 +525,11 @@ ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
= filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
ruleRhsFreeIds :: CoreRule -> VarSet
--- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- ^ This finds all locally-defined free Ids on the right hand side of a rule
-- and returns them as a non-deterministic set
ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet
-ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
- = fvVarSet $ filterFV isLocalId $
- addBndrs bndrs $ exprs_fvs args
+ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
+ = fvVarSet $ filterFV isLocalId $ addBndrs bndrs $ expr_fvs rhs
{-
Note [Rule free var hack] (Not a hack any more)
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Core.Type
import GHC.Core.FVs ( exprFreeIds, ruleRhsFreeIds )
import GHC.Core.Coercion ( Coercion, coVarsOfCo )
import GHC.Core.FamInstEnv
+import GHC.Core.Opt.Arity ( typeArity )
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.Maybe ( isJust )
@@ -59,33 +60,62 @@ data DmdAnalOpts = DmdAnalOpts
{ dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries
}
+-- | Whether we want to store demands on a top-level Id or just default
+-- to 'topDmd'.
+--
+-- Basically, we want to now how top-level *functions* are *used*
+-- (e.g. called), but aren't interested in whether they were called strictly
+-- or not. Other top-level bindings are boring.
+isInterestingTopLevelFn :: Id -> Bool
+-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642
+-- (which is dominated by the Simplifier) at no gain in analysis precision.
+-- If there was a gain, that regression might be acceptable.
+-- Plus, we could use LetUp for thunks and share some code with local let
+-- bindings.
+isInterestingTopLevelFn id =
+ typeArity (idType id) `lengthExceeds` 0
+
-- | Outputs a new copy of the Core program in which binders have been annotated
-- with demand and strictness information.
--
-- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note
-- [Stamp out space leaks in demand analysis])
-dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> CoreProgram -> CoreProgram
-dmdAnalProgram opts fam_envs binds = binds_plus_dmds
- where
- env = emptyAnalEnv opts fam_envs
- binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds
-
--- Analyse a (group of) top-level binding(s)
-dmdAnalTopBind :: AnalEnv
- -> CoreBind
- -> (AnalEnv, CoreBind)
-dmdAnalTopBind env (NonRec id rhs)
- = ( extendAnalEnv TopLevel env id sig
- , NonRec (setIdStrictness id sig) rhs')
+dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
+dmdAnalProgram opts fam_envs rules binds
+ = snd $ go (emptyAnalEnv opts fam_envs) binds
where
- ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env topSubDmd id rhs
+ go _ [] = (nopDmdType, [])
+ go env (b:bs) = case b of
+ NonRec id rhs
+ | (env', lazy_fvs, id', rhs') <- dmdAnalRhsLetDown TopLevel NonRecursive env topSubDmd id rhs
+ , (dmd_ty', bs') <- go env' bs
+ , let dmd_ty'' = add_exported_use env' dmd_ty' id' `addLazyFVs` lazy_fvs
+ , (!dmd_ty''', id_dmd) <- findBndrDmd env' False dmd_ty'' id'
+ , let id'' = annotate_id_dmd id' id_dmd
+ -> (dmd_ty''', NonRec id'' rhs' : bs')
+ Rec pairs
+ | (env', lazy_fvs, pairs') <- dmdFix TopLevel env topSubDmd pairs
+ , let ids' = map fst pairs'
+ , (dmd_ty', bs') <- go env' bs
+ , let dmd_ty'' = add_exported_uses env' dmd_ty' ids' `addLazyFVs` lazy_fvs
+ , (!dmd_ty''', id_dmds) <- findBndrsDmds env' dmd_ty'' ids'
+ , let pairs'' = zipWith (\(id', rhs') dmd -> (annotate_id_dmd id' dmd, rhs')) pairs' id_dmds
+ -> (dmd_ty''', Rec pairs'' : bs')
+
+ annotate_id_dmd id dmd
+ | isInterestingTopLevelFn id
+ = id `setIdDemandInfo` dmd
+ | otherwise
+ = id `setIdDemandInfo` topDmd
-dmdAnalTopBind env (Rec pairs)
- = (env', Rec pairs')
- where
- (env', _, pairs') = dmdFix TopLevel env topSubDmd pairs
- -- We get two iterations automatically
- -- c.f. the NonRec case above
+ add_exported_uses env = foldl' (add_exported_use env)
+ add_exported_use env dmd_ty id
+ | isExportedId id || elemVarSet id rule_fvs
+ -- See Note [Absence analysis for stable unfoldings and RULES]
+ = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
+ | otherwise = dmd_ty
+
+ rule_fvs = foldr (unionVarSet . ruleRhsFreeIds) emptyVarSet rules
{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -194,7 +224,7 @@ dmdAnal' env dmd (App fun arg)
-- Crucially, coercions /are/ handled here, because they are
-- value arguments (#10288)
let
- call_dmd = mkCallDmd dmd
+ call_dmd = mkCalledOnceDmd dmd
(fun_ty, fun') = dmdAnal env call_dmd fun
(arg_dmd, res_ty) = splitDmdTy fun_ty
(arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
@@ -320,9 +350,7 @@ dmdAnal' env dmd (Let (NonRec id rhs) body)
dmdAnal' env dmd (Let (NonRec id rhs) body)
= (body_ty2, Let (NonRec id2 rhs') body')
where
- (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs
- id1 = setIdStrictness id sig
- env1 = extendAnalEnv NotTopLevel env id sig
+ (env1, lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel NonRecursive env dmd id rhs
(body_ty, body') = dmdAnal env1 dmd body
(body_ty1, id2) = annotateBndr env body_ty id1
body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
@@ -344,8 +372,8 @@ dmdAnal' env dmd (Let (Rec pairs) body)
= let
(env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs
(body_ty, body') = dmdAnal env' dmd body
- body_ty1 = deleteFVs body_ty (map fst pairs)
- body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
+ body_ty1 = addLazyFVs body_ty lazy_fv -- see Note [Lazy and unleashable free variables]
+ body_ty2 = deleteFVs body_ty1 (map fst pairs) -- TODO: We could annotate idDemandInfo here
in
body_ty2 `seq`
(body_ty2, Let (Rec pairs') body')
@@ -582,9 +610,13 @@ dmdTransform env var dmd
| Just (sig, top_lvl) <- lookupSigEnv env var
, let fn_ty = dmdTransformSig sig dmd
= -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
- if isTopLevel top_lvl
- then fn_ty -- Don't record demand on top-level things
- else addVarDmd fn_ty var (C_11 :* dmd)
+ case top_lvl of
+ NotTopLevel -> addVarDmd fn_ty var (C_11 :* dmd)
+ TopLevel
+ | isInterestingTopLevelFn var
+ -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* dmd)) -- discard strictness
+ | otherwise
+ -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later
-- Everything else:
-- * Local let binders for which we use LetUp (cf. 'useLetUp')
-- * Lambda binders
@@ -612,33 +644,36 @@ dmdTransform env var dmd
--
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnalRhsLetDown
- :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive
+ :: TopLevelFlag
+ -> RecFlag
-> AnalEnv -> SubDemand
-> Id -> CoreExpr
- -> (DmdEnv, StrictSig, CoreExpr)
+ -> (AnalEnv, DmdEnv, Id, CoreExpr)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
-dmdAnalRhsLetDown rec_flag env let_dmd id rhs
+dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
= -- pprTrace "dmdAnalRhsLetDown" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $
- (lazy_fv, sig, rhs')
+ (env', lazy_fv, id', rhs')
where
rhs_arity = idArity id
+ -- See Note [Demand signatures are computed for a threshold demand based on idArity]
rhs_dmd -- See Note [Demand analysis for join points]
-- See Note [Invariants on join points] invariant 2b, in GHC.Core
-- rhs_arity matches the join arity of the join point
| isJoinId id
- = mkCallDmds rhs_arity let_dmd
+ = mkCalledOnceDmds rhs_arity let_dmd
| otherwise
- -- NB: rhs_arity
- -- See Note [Demand signatures are computed for a threshold demand based on idArity]
- = mkRhsDmd env rhs_arity rhs
+ = mkCalledOnceDmds rhs_arity topSubDmd
(rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs
DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
+ id' = id `setIdStrictness` sig
+ env' = extendAnalEnv top_lvl env id' sig
+
-- See Note [Aggregated demand for cardinality]
-- FIXME: That Note doesn't explain the following lines at all. The reason
-- is really much different: When we have a recursive function, we'd
@@ -651,8 +686,8 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-- we'd have to do an additional iteration. reuseEnv makes sure that
-- we never get used-once info for FVs of recursive functions.
rhs_fv1 = case rec_flag of
- Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
- Nothing -> rhs_fv
+ Recursive -> reuseEnv rhs_fv
+ NonRecursive -> rhs_fv
rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs
-- Find the RHS free vars of the unfoldings and RULES
@@ -669,13 +704,6 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
= exprFreeIds unf_body
| otherwise = emptyVarSet
--- | @mkRhsDmd env rhs_arity rhs@ creates a 'SubDemand' for
--- unleashing on the given function's @rhs@, by creating
--- a call demand of @rhs_arity@
--- See Historical Note [Product demands for function body]
-mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand
-mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity topSubDmd
-
-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines
-- whether we should process the binding up (body before rhs) or down (rhs
-- before body).
@@ -939,8 +967,6 @@ dmdFix :: TopLevelFlag
dmdFix top_lvl env let_dmd orig_pairs
= loop 1 initial_pairs
where
- bndrs = map fst orig_pairs
-
-- See Note [Initialising strictness]
initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
| otherwise = orig_pairs
@@ -990,10 +1016,8 @@ dmdFix top_lvl env let_dmd orig_pairs
= -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $
((env', lazy_fv'), (id', rhs'))
where
- (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
- lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1
- env' = extendAnalEnv top_lvl env id sig
- id' = setIdStrictness id sig
+ (env', lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl Recursive env let_dmd id rhs
+ lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1
zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -65,6 +65,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic
+import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
@@ -495,7 +496,7 @@ doCorePass CoreDoExitify = {-# SCC "Exitify" #-}
doPass exitifyProgram
doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-}
- doPassDFM dmdAnal
+ doPassDFRM dmdAnal
doCorePass CoreDoCpr = {-# SCC "CprAnal" #-}
doPassDFM cprAnalProgram
@@ -575,6 +576,13 @@ doPassDFM do_pass guts = do
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
doPassM (liftIO . do_pass dflags fam_envs) guts
+doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFRM do_pass guts = do
+ dflags <- getDynFlags
+ p_fam_env <- getPackageFamInstEnv
+ let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+ doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts
+
doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFU do_pass guts = do
dflags <- getDynFlags
@@ -1088,13 +1096,13 @@ transferIdInfo exported_id local_id
-dmdAnal :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
-dmdAnal dflags fam_envs binds = do
+dmdAnal :: DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
+dmdAnal dflags fam_envs rules binds = do
let opts = DmdAnalOpts
{ dmd_strict_dicts = gopt Opt_DictsStrict dflags
}
- binds_plus_dmds = dmdAnalProgram opts fam_envs binds
+ binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds
Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $
- dumpIdInfoOfProgram (ppr . strictnessInfo) binds_plus_dmds
+ dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds
-- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
seqBinds binds_plus_dmds `seq` return binds_plus_dmds
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -1275,10 +1275,14 @@ mk_absent_let dflags fam_envs arg
abs_rhs = mkAbsentErrorApp arg_ty msg
msg = showSDoc (gopt_set dflags Opt_SuppressUniques)
- (ppr arg <+> ppr (idType arg) <+> file_msg)
+ (vcat
+ [ text "Arg:" <+> ppr arg
+ , text "Type:" <+> ppr arg_ty
+ , file_msg
+ ])
file_msg = case outputFile dflags of
Nothing -> empty
- Just f -> text "in output file " <+> quotes (text f)
+ Just f -> text "In output file " <+> quotes (text f)
-- We need to suppress uniques here because otherwise they'd
-- end up in the generated code as strings. This is bad for
-- determinism, because with different uniques the strings
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -21,7 +21,7 @@ import GHC.Core
import GHC.Core.Seq ( seqUnfolding )
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Types.Demand ( zapUsageEnvSig )
+import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Core.Type ( tidyType, tidyVarBndr )
import GHC.Core.Coercion ( tidyCo )
import GHC.Types.Var
@@ -206,7 +206,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id
new_info = vanillaIdInfo
`setOccInfo` occInfo old_info
`setArityInfo` arityInfo old_info
- `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info)
+ `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info)
`setDemandInfo` demandInfo old_info
`setInlinePragInfo` inlinePragInfo old_info
`setUnfoldingInfo` new_unf
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Types.Demand (
lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
-- ** Other @Demand@ operations
oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand,
- peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,
+ peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,
addCaseBndrDmd,
-- ** Extracting one-shot information
argOneShots, argsOneShots, saturatedByOneShots,
@@ -73,7 +73,7 @@ module GHC.Types.Demand (
seqDemand, seqDemandList, seqDmdType, seqStrictSig,
-- * Zapping usage information
- zapUsageDemand, zapUsageEnvSig, zapUsedOnceDemand, zapUsedOnceSig
+ zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig
) where
#include "HsVersions.h"
@@ -278,7 +278,8 @@ data SubDemand
-- ^ @Call n sd@ describes the evaluation context of @n@ function
-- applications, where every individual result is evaluated according to @sd at .
-- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative].
- -- Used only for values of function type.
+ -- Used only for values of function type. Use the smart constructor 'mkCall'
+ -- whenever possible!
| Prod ![Demand]
-- ^ @Prod ds@ describes the evaluation context of a case scrutinisation
-- on an expression of product type, where the product components are
@@ -306,7 +307,7 @@ polyDmd C_1N = C_1N :* poly1N
polyDmd C_10 = C_10 :* poly10
-- | A smart constructor for 'Prod', applying rewrite rules along the semantic
--- equalities @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'
+-- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'
-- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a
-- polymorphic demand will never unbox.
mkProd :: [Demand] -> SubDemand
@@ -335,6 +336,13 @@ viewProd _ _ = Nothing
{-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation
-- for Arity. Otherwise, #18304 bites us.
+-- | A smart constructor for 'Call', applying rewrite rules along the semantic
+-- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's
+-- when possible.
+mkCall :: Card -> SubDemand -> SubDemand
+mkCall n cd@(Poly m) | n == m = cd
+mkCall n cd = Call n cd
+
-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as
-- necessary.
viewCall :: SubDemand -> Maybe (Card, SubDemand)
@@ -356,8 +364,8 @@ lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
-- Handle Call
lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))
-- See Note [Call demands are relative]
- | isAbs n2 = Call (lubCard n1 n2) (lubSubDmd d1 botSubDmd)
- | otherwise = Call (lubCard n1 n2) (lubSubDmd d1 d2)
+ | isAbs n2 = mkCall (lubCard n1 n2) (lubSubDmd d1 botSubDmd)
+ | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2)
-- Handle Poly
lubSubDmd (Poly n1) (Poly n2) = Poly (lubCard n1 n2)
-- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -377,8 +385,8 @@ plusSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
-- Handle Call
plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))
-- See Note [Call demands are relative]
- | isAbs n2 = Call (plusCard n1 n2) (lubSubDmd d1 botSubDmd)
- | otherwise = Call (plusCard n1 n2) (lubSubDmd d1 d2)
+ | isAbs n2 = mkCall (plusCard n1 n2) (lubSubDmd d1 botSubDmd)
+ | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1 d2)
-- Handle Poly
plusSubDmd (Poly n1) (Poly n2) = Poly (plusCard n1 n2)
-- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -407,7 +415,7 @@ multSubDmd :: Card -> SubDemand -> SubDemand
multSubDmd n sd
| Just sd' <- multTrivial n seqSubDmd sd = sd'
multSubDmd n (Poly n') = Poly (multCard n n')
-multSubDmd n (Call n' sd) = Call (multCard n n') sd -- See Note [Call demands are relative]
+multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]
multSubDmd n (Prod ds) = Prod (map (multDmd n) ds)
multDmd :: Card -> Demand -> Demand
@@ -457,22 +465,22 @@ evalDmd = C_1N :* topSubDmd
-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @SCS(U)@.
-- Called exactly once.
strictOnceApply1Dmd :: Demand
-strictOnceApply1Dmd = C_11 :* Call C_11 topSubDmd
+strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd
-- | First argument of 'GHC.Exts.atomically#': @MCM(U)@.
-- Called at least once, possibly many times.
strictManyApply1Dmd :: Demand
-strictManyApply1Dmd = C_1N :* Call C_1N topSubDmd
+strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd
-- | First argument of catch#: @1C1(U)@.
-- Evaluates its arg lazily, but then applies it exactly once to one argument.
lazyApply1Dmd :: Demand
-lazyApply1Dmd = C_01 :* Call C_01 topSubDmd
+lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd
-- | Second argument of catch#: @1C1(CS(U))@.
-- Calls its arg lazily, but then applies it exactly once to an additional argument.
lazyApply2Dmd :: Demand
-lazyApply2Dmd = C_01 :* Call C_01 (Call C_11 topSubDmd)
+lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)
-- | Make a 'Demand' evaluated at-most-once.
oneifyDmd :: Demand -> Demand
@@ -512,12 +520,12 @@ strictifyDictDmd ty (n :* Prod ds)
strictifyDictDmd _ dmd = dmd
-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @CS(d)@.
-mkCallDmd :: SubDemand -> SubDemand
-mkCallDmd sd = Call C_11 sd
+mkCalledOnceDmd :: SubDemand -> SubDemand
+mkCalledOnceDmd sd = mkCall C_11 sd
--- | @mkCallDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.
-mkCallDmds :: Arity -> SubDemand -> SubDemand
-mkCallDmds arity sd = iterate mkCallDmd sd !! arity
+-- | @mkCalledOnceDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.
+mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand
+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.
@@ -669,7 +677,7 @@ This is needed even for non-product types, in case the case-binder
is used but the components of the case alternative are not.
Note [Don't optimise UP(U,U,...) to U]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These two SubDemands:
UP(U,U) (@Prod [topDmd, topDmd]@) and U (@topSubDmd@)
are semantically equivalent, but we do not turn the former into
@@ -1571,9 +1579,9 @@ This is weird, so I'm not worried about whether this optimises brilliantly; but
it should not fall over.
-}
-zapUsageEnvSig :: StrictSig -> StrictSig
--- Remove the usage environment from the demand
-zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r
+-- | Remove the demand environment from the signature.
+zapDmdEnvSig :: StrictSig -> StrictSig
+zapDmdEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r
zapUsageDemand :: Demand -> Demand
-- Remove the usage info, but not the strictness info, from the demand
@@ -1615,8 +1623,8 @@ kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd
kill_usage_sd :: KillFlags -> SubDemand -> SubDemand
kill_usage_sd kfs (Call n sd)
- | kf_called_once kfs = Call (lubCard C_1N n) (kill_usage_sd kfs sd)
- | otherwise = Call n (kill_usage_sd kfs sd)
+ | kf_called_once kfs = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)
+ | otherwise = mkCall n (kill_usage_sd kfs sd)
kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds)
kill_usage_sd _ sd = sd
@@ -1640,7 +1648,7 @@ trimToType (n :* sd) ts
where
go (Prod ds) (TsProd tss)
| equalLength ds tss = Prod (zipWith trimToType ds tss)
- go (Call n sd) (TsFun ts) = Call n (go sd ts)
+ go (Call n sd) (TsFun ts) = mkCall n (go sd ts)
go sd at Poly{} _ = sd
go _ _ = topSubDmd
@@ -1804,7 +1812,7 @@ instance Binary SubDemand where
h <- getByte bh
case h of
0 -> Poly <$> get bh
- 1 -> Call <$> get bh <*> get bh
+ 1 -> mkCall <$> get bh <*> get bh
2 -> Prod <$> get bh
_ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -650,7 +650,7 @@ zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
zapUsageEnvInfo :: IdInfo -> Maybe IdInfo
zapUsageEnvInfo info
| hasDemandEnvSig (strictnessInfo info)
- = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})
+ = Just (info {strictnessInfo = zapDmdEnvSig (strictnessInfo info)})
| otherwise
= Nothing
=====================================
testsuite/tests/arityanal/should_compile/Arity11.stderr
=====================================
@@ -35,7 +35,7 @@ end Rec }
-- RHS size: {terms: 52, types: 28, 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,UCU(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}]
+[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
= \ (@a) (@p) (ww :: a -> a -> Bool) (w :: Num a) (w1 :: Num p) (w2 :: a) ->
let {
@@ -73,7 +73,7 @@ F11.$wfib
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,UCU(U))><UP(UCU(CS(U)),A,A,A,A,A,UCU(U))><U>,
+ 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 }
=====================================
testsuite/tests/arityanal/should_compile/Arity16.stderr
=====================================
@@ -5,7 +5,7 @@ Result size of Tidy Core = {terms: 52, types: 87, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 15, types: 17, coercions: 0, joins: 0/0}
map2 [Occ=LoopBreaker] :: forall {t} {a}. (t -> a) -> [t] -> [a]
-[GblId, Arity=2, Str=<UCU(U)><SU>, Unf=OtherCon []]
+[GblId, Arity=2, Str=<U><SU>, Unf=OtherCon []]
map2
= \ (@t) (@a) (f :: t -> a) (ds :: [t]) ->
case ds of {
=====================================
testsuite/tests/stranal/should_compile/T18894.hs
=====================================
@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+-- | The point of this test is that @g*@ get's a demand that says
+-- "whenever @g*@ is called, the second component of the pair is evaluated strictly".
+module T18894 (h1, h2) where
+
+g1 :: Int -> (Int,Int)
+g1 1 = (15, 0)
+g1 n = (2 * n, 2 `div` n)
+{-# NOINLINE g1 #-}
+
+h1 :: Int -> Int
+h1 1 = 0
+-- Sadly, the @g1 2@ subexpression will be floated to top-level, where we
+-- don't see the specific demand placed on it by @snd at . Tracked in #19001.
+h1 2 = snd (g1 2)
+h1 m = uncurry (+) (g1 m)
+
+g2 :: Int -> Int -> (Int,Int)
+g2 m 1 = (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)
=====================================
testsuite/tests/stranal/should_compile/T18894.stderr
=====================================
@@ -0,0 +1,404 @@
+
+==================== Demand analysis ====================
+Result size of Demand analysis
+ = {terms: 177, types: 97, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T18894"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18894.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ 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: 36, types: 16, coercions: 0, joins: 0/0}
+g2 [InlPrag=NOINLINE, Dmd=UCU(CS(P(1P(U),SP(U))))]
+ :: Int -> Int -> (Int, Int)
+[LclId,
+ Arity=2,
+ Str=<UP(U)><SP(SU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 161 20}]
+g2
+ = \ (m [Dmd=UP(U)] :: Int) (ds [Dmd=SP(SU)] :: Int) ->
+ case ds of { GHC.Types.I# ds [Dmd=SU] ->
+ case ds of ds [Dmd=1U] {
+ __DEFAULT ->
+ (case m of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# 2# y) },
+ case ds of wild {
+ __DEFAULT ->
+ case GHC.Classes.divInt# 2# wild of ww4 { __DEFAULT ->
+ GHC.Types.I# ww4
+ };
+ -1# -> GHC.Types.I# -2#;
+ 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }
+ });
+ 1# -> (m, lvl)
+ }
+ }
+
+-- 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: 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: 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: 36, types: 19, coercions: 0, joins: 0/0}
+h2 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(MU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 162 10}]
+h2
+ = \ (ds [Dmd=SP(MU)] :: Int) ->
+ case ds of wild [Dmd=UP(U)] { GHC.Types.I# ds [Dmd=MU] ->
+ case ds of ds {
+ __DEFAULT ->
+ case GHC.Prim.remInt# ds 2# of {
+ __DEFAULT ->
+ case g2 wild lvl of { (ds1 [Dmd=A], y [Dmd=SU]) -> y };
+ 0# ->
+ case g2 lvl wild of { (x [Dmd=SP(U)], ds [Dmd=SP(U)]) ->
+ case x of { GHC.Types.I# x ->
+ case ds of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) }
+ }
+ }
+ };
+ 1# -> lvl
+ }
+ }
+
+-- 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#
+
+-- 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: 3, types: 2, coercions: 0, joins: 0/0}
+lvl :: (Int, Int)
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = (lvl, lvl)
+
+-- RHS size: {terms: 30, types: 11, coercions: 0, joins: 0/0}
+g1 [InlPrag=NOINLINE, Dmd=UCU(P(UP(U),UP(U)))] :: Int -> (Int, Int)
+[LclId,
+ Arity=1,
+ Str=<SP(SU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 141 10}]
+g1
+ = \ (ds [Dmd=SP(SU)] :: Int) ->
+ case ds of { GHC.Types.I# ds [Dmd=SU] ->
+ case ds of ds {
+ __DEFAULT ->
+ (GHC.Types.I# (GHC.Prim.*# 2# ds),
+ case ds of wild {
+ __DEFAULT ->
+ case GHC.Classes.divInt# 2# wild of ww4 { __DEFAULT ->
+ GHC.Types.I# ww4
+ };
+ -1# -> GHC.Types.I# -2#;
+ 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }
+ });
+ 1# -> lvl
+ }
+ }
+
+-- 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: 3, types: 0, coercions: 0, joins: 0/0}
+lvl :: (Int, Int)
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}]
+lvl = g1 (GHC.Types.I# 2#)
+
+-- RHS size: {terms: 28, types: 18, coercions: 0, joins: 0/0}
+h1 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(MU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 111 10}]
+h1
+ = \ (ds [Dmd=SP(MU)] :: Int) ->
+ case ds of wild [Dmd=1P(1U)] { GHC.Types.I# ds [Dmd=MU] ->
+ case ds of {
+ __DEFAULT ->
+ case g1 wild of { (x [Dmd=SP(U)], ds [Dmd=SP(U)]) ->
+ case x of { GHC.Types.I# x ->
+ case ds of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) }
+ }
+ };
+ 1# -> lvl;
+ 2# -> case lvl of { (ds1 [Dmd=A], y [Dmd=SU]) -> y }
+ }
+ }
+
+
+
+
+==================== Demand analysis ====================
+Result size of Demand analysis
+ = {terms: 171, types: 120, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T18894"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18894.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ 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 #)
+[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}]
+$wg2
+ = \ (w [Dmd=UP(U)] :: Int) (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww of ds {
+ __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 #)
+ }
+
+-- 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: 34, types: 21, coercions: 0, joins: 0/0}
+$wh2 [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 [30] 162 10}]
+$wh2
+ = \ (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww of ds {
+ __DEFAULT ->
+ case GHC.Prim.remInt# ds 2# of {
+ __DEFAULT ->
+ case $wg2 (GHC.Types.I# ds) 2# of
+ { (# ww [Dmd=A], ww [Dmd=SU] #) ->
+ 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) }
+ }
+ }
+ };
+ 1# -> lvl
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+h2 [InlPrag=[2]] :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(SU)>,
+ 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 }}]
+h2
+ = \ (w [Dmd=SP(SU)] :: Int) ->
+ case w of { GHC.Types.I# ww [Dmd=SU] -> $wh2 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#
+
+-- 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 #)
+[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}]
+$wg1
+ = \ (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww 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# -> lvl;
+ 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }
+ } #);
+ 1# -> (# lvl, lvl #)
+ }
+
+-- RHS size: {terms: 7, types: 9, coercions: 0, joins: 0/0}
+lvl :: (Int, Int)
+[LclId,
+ 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) }
+
+-- RHS size: {terms: 25, types: 18, 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}]
+$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) }
+ }
+ };
+ 1# -> lvl;
+ 2# -> case lvl of { (ds1 [Dmd=A], y [Dmd=SU]) -> y }
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+h1 [InlPrag=[2]] :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(SU)>,
+ 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] -> $wh1 ww }}]
+h1
+ = \ (w [Dmd=SP(SU)] :: Int) ->
+ case w of { GHC.Types.I# ww [Dmd=SU] -> $wh1 ww }
+
+
+
=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -58,3 +58,5 @@ test('T18122', [ grep_errmsg(r'wfoo =') ], compile, ['-ddump-simpl'])
# We care about the call demand on $wg
test('T18903', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-simpl -dsuppress-uniques'])
+# We care about the call demand on $wg1 and $wg2
+test('T18894', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-stranal -dsuppress-uniques'])
=====================================
testsuite/tests/stranal/sigs/T5075.stderr
=====================================
@@ -1,7 +1,7 @@
==================== 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,UCU(U))><U>
+T5075.loop: <MP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U>
@@ -13,6 +13,6 @@ 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,UCU(U))><U>
+T5075.loop: <SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U>
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/549af6957748293cd497ccbef421c30666b56f31...3a7344fb01f296a88e8136de47a81a5d2448d795
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/549af6957748293cd497ccbef421c30666b56f31...3a7344fb01f296a88e8136de47a81a5d2448d795
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201127/84b1f534/attachment-0001.html>
More information about the ghc-commits
mailing list