[Git][ghc/ghc][wip/nested-cpr-2019] WorkWrap CPR: Consider how a function body is used
Sebastian Graf
gitlab at gitlab.haskell.org
Thu Dec 17 16:16:44 UTC 2020
Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC
Commits:
4c15c483 by Sebastian Graf at 2020-12-17T17:15:50+01:00
WorkWrap CPR: Consider how a function body is used
Consider `T18894`:
```hs
module T18894 (h) where
g :: Int -> Int -> (Int,Int)
g !m 1 = (2 + 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)
```
We give `g` the CPR type `#c1(#c1(*), *c1(#))`. Previously, that
wouldn't let us unbox the second component, because the division
might diverge (throw a div-by-zero exception).
But since #18894/!4493, we annotate `g` with its demand
`UCU(CS(P(1P(U),SP(U))))`.
Note that demand tells us that, *when* `g` is called, we always
evaluate the second component of the returned pair. So it's OK for W/W
to unbox it, because all call sites will force the division anyway!
This is what this commit is implementing. The changes are entirely
local to W/W.
I also added a test case, `T18174`, that tracks everything Nested CPR is
supposed to do (which is tracked in #18174).
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Types/Cpr.hs
- + testsuite/tests/cpranal/should_compile/T18174.hs
- + testsuite/tests/cpranal/should_compile/T18174.stderr
- testsuite/tests/cpranal/should_compile/all.T
- testsuite/tests/cpranal/sigs/T1600.hs
- testsuite/tests/cpranal/sigs/T1600.stderr
- testsuite/tests/stranal/should_compile/T18894.stderr
Changes:
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -482,7 +482,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 forced_cpr rhs
| isNonRec is_rec, is_thunk -- See Note [Thunk splitting]
= splitThunk dflags fam_envs is_rec new_fn_id rhs
@@ -491,9 +491,9 @@ 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)
+ uf_opts = unfoldingOpts dflags
+ fn_info = idInfo fn_id
+ (wrap_arg_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.
@@ -501,14 +501,21 @@ tryWW dflags fam_envs is_rec fn_id rhs
cpr = ASSERT2( isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info
, ppr fn_id <> colon <+> text "ct_arty:" <+> ppr (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info))
ct_cpr cpr_ty
+ -- 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.
+ (_card1 :* fn_sd) = demandInfo fn_info -- describes how the function was called
+ (_card2, wrap_body_sd) = peelManyCalls (length wrap_arg_dmds) fn_sd
+ -- Force the recorded CPR (and Termination information!) according to how
+ -- the function is used.
+ (_tm, forced_cpr) = forceCpr wrap_body_sd cpr
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))
@@ -586,10 +593,10 @@ See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.
---------------------
splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr
-> UniqSM [(Id, CoreExpr)]
-splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
- = 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 cpr rhs
+ = WARN( not (wrap_arg_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_arg_dmds $$ ppr cpr) ) do
-- The arity should match the signature
- stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr
+ stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_arg_dmds use_cpr
case stuff of
Just (work_demands, join_arity, wrap_fn, work_fn) -> do
work_uniq <- getUniqueM
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -132,11 +132,12 @@ type WwResult
mkWwBodies :: DynFlags
-> FamInstEnvs
- -> VarSet -- Free vars of RHS
+ -> VarSet -- ^ Free vars of RHS
-- See Note [Freshen WW arguments]
- -> Id -- The original function
- -> [Demand] -- Strictness of original function
- -> Cpr -- Info about function result
+ -> Id -- ^ The original function
+ -> [Demand] -- ^ Strictness of original function
+ -- (derived from 'idStrictness')
+ -> Cpr -- ^ Info about function result
-> UniqSM (Maybe WwResult)
-- wrap_fn_args E = \x y -> E
@@ -150,12 +151,12 @@ mkWwBodies :: DynFlags
-- let x = (a,b) in
-- E
-mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
+mkWwBodies dflags fam_envs rhs_fvs fun_id arg_dmds cpr_info
= 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 dflags fam_envs has_inlineable_prag wrap_args
@@ -168,7 +169,7 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
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 dflags (length demands) work_args
+ ; if isWorkerSmallEnough dflags (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,
@@ -190,7 +191,7 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
-- 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
@@ -221,9 +222,9 @@ isWorkerSmallEnough dflags 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
@@ -1085,9 +1086,7 @@ mkWWcpr opt_CprAnal fam_envs body_ty cpr
| not opt_CprAnal = return (False, id, id, body_ty)
-- CPR is turned on by default for -O and O2
| otherwise = do
- -- We assume WHNF, so the outer layer always terminates.
- let (_tm, cpr') = forceCpr seqDmd cpr
- mb_stuff <- mkWWcpr_one_layer fam_envs body_ty cpr'
+ mb_stuff <- mkWWcpr_one_layer fam_envs body_ty cpr
case mb_stuff of
Nothing -> return (False, id, id, body_ty)
Just stuff -> do
=====================================
compiler/GHC/Types/Cpr.hs
=====================================
@@ -475,8 +475,8 @@ forceTermM sd (Term tf l_sh) = do
_ -> return l_sh -- just don't force anything
return (Term Terminates l_sh')
-forceCpr :: Demand -> Cpr -> (TerminationFlag, Cpr)
-forceCpr dmd cpr = runTerminationM (idIfLazy forceCprM dmd cpr)
+forceCpr :: SubDemand -> Cpr -> (TerminationFlag, Cpr)
+forceCpr sd cpr = runTerminationM (forceCprM sd cpr)
-- | 'lubTerm's the given outer @TerminationFlag@ on the @CprType at s 'ct_term'.
bothCprType :: CprType -> TerminationFlag -> CprType
=====================================
testsuite/tests/cpranal/should_compile/T18174.hs
=====================================
@@ -0,0 +1,66 @@
+{-# 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')
+
+----------------------------------------------------------------------
+-- 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 at . 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)
=====================================
testsuite/tests/cpranal/should_compile/T18174.stderr
=====================================
@@ -0,0 +1,167 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 336, types: 368, 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_r1mk :: Int
+lvl_r1mk = GHC.Types.I# 1#
+
+Rec {
+-- RHS size: {terms: 38, types: 38, coercions: 0, joins: 0/1}
+T18174.$wfac3 :: forall {a}. GHC.Prim.Int# -> a -> (# a, Int #)
+T18174.$wfac3
+ = \ (@a_s1d4) (ww_s1d9 :: GHC.Prim.Int#) (w_s1d6 :: a_s1d4) ->
+ case GHC.Prim.<# ww_s1d9 2# of {
+ __DEFAULT ->
+ let {
+ ds_s186 :: (a_s1d4, Int)
+ ds_s186 = case T18174.$wfac3 @a_s1d4 (GHC.Prim.-# ww_s1d9 1#) w_s1d6 of { (# ww2_s1dd, ww3_s1de #) -> (ww2_s1dd, ww3_s1de) } } in
+ (# case ds_s186 of { (s'_aXb, n'_aXc) -> s'_aXb }, case ds_s186 of { (s'_aXb, n'_aXc) -> case n'_aXc of { GHC.Types.I# ww2_s1d2 -> GHC.Types.I# (GHC.Prim.*# ww2_s1d2 ww2_s1d2) } } #);
+ 1# -> (# w_s1d6, lvl_r1mk #)
+ }
+end Rec }
+
+-- RHS size: {terms: 14, types: 16, coercions: 0, joins: 0/0}
+fac3 :: forall a. Int -> a -> (a, Int)
+fac3 = \ (@a_s1d4) (w_s1d5 :: Int) (w1_s1d6 :: a_s1d4) -> case w_s1d5 of { GHC.Types.I# ww1_s1d9 -> case T18174.$wfac3 @a_s1d4 ww1_s1d9 w1_s1d6 of { (# ww3_s1dd, ww4_s1de #) -> (ww3_s1dd, ww4_s1de) } }
+
+Rec {
+-- RHS size: {terms: 24, types: 21, coercions: 0, joins: 0/0}
+T18174.$wfac2 :: forall {a}. GHC.Prim.Int# -> a -> (# a, GHC.Prim.Int# #)
+T18174.$wfac2
+ = \ (@a_s1dh) (ww_s1dm :: GHC.Prim.Int#) (w_s1dj :: a_s1dh) ->
+ case GHC.Prim.<# ww_s1dm 2# of {
+ __DEFAULT -> case T18174.$wfac2 @a_s1dh (GHC.Prim.-# ww_s1dm 1#) w_s1dj of { (# ww2_s1ds, ww3_s1du #) -> (# ww2_s1ds, GHC.Prim.*# ww3_s1du ww3_s1du #) };
+ 1# -> (# w_s1dj, 1# #)
+ }
+end Rec }
+
+-- RHS size: {terms: 15, types: 16, coercions: 0, joins: 0/0}
+fac2 :: forall a. Int -> a -> (a, Int)
+fac2 = \ (@a_s1dh) (w_s1di :: Int) (w1_s1dj :: a_s1dh) -> case w_s1di of { GHC.Types.I# ww1_s1dm -> case T18174.$wfac2 @a_s1dh ww1_s1dm w1_s1dj of { (# ww3_s1ds, ww4_s1du #) -> (ww3_s1ds, GHC.Types.I# ww4_s1du) } }
+
+Rec {
+-- RHS size: {terms: 24, types: 21, coercions: 0, joins: 0/0}
+T18174.$wfac1 :: forall {a}. GHC.Prim.Int# -> a -> (# a, GHC.Prim.Int# #)
+T18174.$wfac1
+ = \ (@a_s1dx) (ww_s1dC :: GHC.Prim.Int#) (w_s1dz :: a_s1dx) ->
+ case GHC.Prim.<# ww_s1dC 2# of {
+ __DEFAULT -> case T18174.$wfac1 @a_s1dx (GHC.Prim.-# ww_s1dC 1#) w_s1dz of { (# ww2_s1dI, ww3_s1dK #) -> (# ww2_s1dI, GHC.Prim.*# ww_s1dC ww3_s1dK #) };
+ 1# -> (# w_s1dz, 1# #)
+ }
+end Rec }
+
+-- RHS size: {terms: 15, types: 16, coercions: 0, joins: 0/0}
+fac1 :: forall a. Int -> a -> (a, Int)
+fac1 = \ (@a_s1dx) (w_s1dy :: Int) (w1_s1dz :: a_s1dx) -> case w_s1dy of { GHC.Types.I# ww1_s1dC -> case T18174.$wfac1 @a_s1dx ww1_s1dC w1_s1dz of { (# ww3_s1dI, ww4_s1dK #) -> (ww3_s1dI, GHC.Types.I# ww4_s1dK) } }
+
+-- RHS size: {terms: 30, types: 19, coercions: 0, joins: 0/0}
+T18174.$wg2 :: GHC.Prim.Int# -> GHC.Prim.Int# -> (# GHC.Prim.Int#, GHC.Prim.Int# #)
+T18174.$wg2
+ = \ (ww_s1dR :: GHC.Prim.Int#) (ww1_s1dV :: GHC.Prim.Int#) ->
+ case ww1_s1dV of ds_X2 {
+ __DEFAULT -> case GHC.Classes.divInt# 2# ds_X2 of ww4_a153 { __DEFAULT -> (# GHC.Prim.*# 2# ww_s1dR, ww4_a153 #) };
+ -1# -> (# GHC.Prim.*# 2# ww_s1dR, -2# #);
+ 0# -> case GHC.Real.divZeroError of wild_00 { };
+ 1# -> (# GHC.Prim.+# 2# ww_s1dR, 0# #)
+ }
+
+-- RHS size: {terms: 26, types: 17, coercions: 0, joins: 0/0}
+T18174.$wh2 :: GHC.Prim.Int# -> GHC.Prim.Int#
+T18174.$wh2
+ = \ (ww_s1ed :: GHC.Prim.Int#) ->
+ case ww_s1ed of ds_X2 {
+ __DEFAULT ->
+ case GHC.Prim.remInt# ds_X2 2# of {
+ __DEFAULT -> case T18174.$wg2 ds_X2 2# of { (# ww2_s1e4, ww3_s1e7 #) -> ww3_s1e7 };
+ 0# -> case T18174.$wg2 2# ds_X2 of { (# ww2_s1e4, ww3_s1e7 #) -> GHC.Prim.+# ww2_s1e4 ww3_s1e7 }
+ };
+ 1# -> 0#
+ }
+
+-- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0}
+h2 :: Int -> Int
+h2 = \ (w_s1ea :: Int) -> case w_s1ea of { GHC.Types.I# ww1_s1ed -> case T18174.$wh2 ww1_s1ed of ww2_s1eh { __DEFAULT -> GHC.Types.I# ww2_s1eh } }
+
+-- 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_r1ml :: Int
+lvl1_r1ml = GHC.Types.I# -2#
+
+-- RHS size: {terms: 27, types: 15, coercions: 0, joins: 0/0}
+T18174.$wg1 :: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #)
+T18174.$wg1
+ = \ (ww_s1en :: GHC.Prim.Int#) ->
+ case ww_s1en of ds_X2 {
+ __DEFAULT ->
+ (# GHC.Prim.*# 2# ds_X2,
+ case ds_X2 of {
+ __DEFAULT -> case GHC.Classes.divInt# 2# ds_X2 of ww4_a153 { __DEFAULT -> GHC.Types.I# ww4_a153 };
+ -1# -> lvl1_r1ml;
+ 0# -> case GHC.Real.divZeroError of wild1_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 { (# ww1_s1eu, ww2_s1ew #) -> (GHC.Types.I# ww1_s1eu, ww2_s1ew) }
+
+-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0}
+T18174.$wh1 :: GHC.Prim.Int# -> Int
+T18174.$wh1
+ = \ (ww_s1eC :: GHC.Prim.Int#) ->
+ case ww_s1eC of ds_X2 {
+ __DEFAULT -> case T18174.$wg1 ds_X2 of { (# ww2_s1eu, ww3_s1ew #) -> case ww3_s1ew of { GHC.Types.I# y_a15e -> GHC.Types.I# (GHC.Prim.+# ww2_s1eu y_a15e) } };
+ 1# -> T18174.h5;
+ 2# -> case T18174.h4 of { (ds1_a137, y_a138) -> y_a138 }
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+h1 :: Int -> Int
+h1 = \ (w_s1ez :: Int) -> case w_s1ez of { GHC.Types.I# ww1_s1eC -> T18174.$wh1 ww1_s1eC }
+
+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_s1eJ :: GHC.Prim.Int#) (w_s1eG :: GHC.Prim.State# GHC.Prim.RealWorld) ->
+ case GHC.Prim.<# ww_s1eJ 2# of {
+ __DEFAULT -> case T18174.$wfacIO (GHC.Prim.-# ww_s1eJ 1#) w_s1eG of { (# ww2_s1eP, ww3_s1eR #) -> (# ww2_s1eP, GHC.Prim.*# ww_s1eJ ww3_s1eR #) };
+ 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# ww1_s1eJ -> case T18174.$wfacIO ww1_s1eJ w1_s1eG of { (# ww3_s1eP, ww4_s1eR #) -> (# ww3_s1eP, GHC.Types.I# ww4_s1eR #) } }
+
+-- 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))
+
+
+
=====================================
testsuite/tests/cpranal/should_compile/all.T
=====================================
@@ -5,3 +5,5 @@ def f( name, opts ):
setTestOpts(f)
test('Cpr001', [], multimod_compile, ['Cpr001', '-v0'])
+# The following test greps for type signatures of worker functions.
+test('T18174', [ grep_errmsg(r'^T18174\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999'])
=====================================
testsuite/tests/cpranal/sigs/T1600.hs
=====================================
@@ -1,23 +1,5 @@
-module Lib where
-
-
--- 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')
+-- | Basically tests Nested CPR on IO.
+module T1600 where
facIO :: Int -> IO Int
facIO n | n < 2 = return 1
=====================================
testsuite/tests/cpranal/sigs/T1600.stderr
=====================================
@@ -1,9 +1,6 @@
==================== Cpr signatures ====================
-Lib.$trModule: *
-Lib.fac1: *c1(*, #c1(#))
-Lib.fac2: *c1(*, #c1(#))
-Lib.fac3: *c1(*, *c1(#))
-Lib.facIO: *c1(*, #c1(#))
+T1600.$trModule: *
+T1600.facIO: *c1(*, #c1(#))
=====================================
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: 36, types: 23, coercions: 0, joins: 0/0}
+-- 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 0}]
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 142 0}]
$wh2
= \ (ww [Dmd=SU] :: GHC.Prim.Int#) ->
case ww of ds {
@@ -301,14 +286,12 @@ $wh2
case GHC.Prim.remInt# ds 2# of {
__DEFAULT ->
case $wg2 (GHC.Types.I# ds) 2# of
- { (# ww [Dmd=A], ww [Dmd=SP(SU)] #) ->
- case ww of { GHC.Types.I# ww [Dmd=SU] -> ww }
+ { (# 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.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# -> 0#
@@ -333,6 +316,20 @@ h2
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# 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: 27, types: 15, coercions: 0, joins: 0/0}
$wg1 [InlPrag=NOINLINE, Dmd=UCU(P(U,UP(U)))]
:: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c15c4838615ca8899a1e7afcdd42dd0e74f2a2c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c15c4838615ca8899a1e7afcdd42dd0e74f2a2c
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/20201217/0c0c6be2/attachment-0001.html>
More information about the ghc-commits
mailing list