[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 18:19:30 UTC 2020



Sebastian Graf pushed to branch wip/nested-cpr-2019 at Glasgow Haskell Compiler / GHC


Commits:
3a0802dc by Sebastian Graf at 2020-12-17T19:19:21+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).

- - - - -


11 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/simplCore/should_compile/T3772.stdout
- testsuite/tests/stranal/should_compile/T18894.stderr
- testsuite/tests/stranal/should_compile/T18903.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/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=#, Unf=OtherCon []]
 $wxs
   = \ (ww :: GHC.Prim.Int#) ->
       case ww of ds1 {


=====================================
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 #)


=====================================
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: 79, types: 55, coercions: 0, joins: 0/1}
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T18903.$trModule4 :: GHC.Prim.Addr#
@@ -44,66 +44,60 @@ 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#
+T18903.h1 = GHC.Types.I# -2#
 
--- 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: 50, types: 41, 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] 222 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(1P(U),U))]
+          :: GHC.Prim.Int# -> (# 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 ww4 { __DEFAULT ->
+                  (# GHC.Types.I# (GHC.Prim.*# 2# ds), ww4 #)
+                  };
+                -1# -> (# T18903.h1, -2# #);
+                0# -> case GHC.Real.divZeroError of wild { };
+                1# -> (# GHC.Types.I# 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) }
-          }
+          case ww2 of { GHC.Types.I# x -> GHC.Prim.+# x ww3 }
           };
-        1# -> T18903.h1;
+        1# -> 0#;
         2# -> case $wg 2# of { (# ww2, ww3 #) -> ww3 }
       }
 
--- 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# ww1 [Occ=Once1] ->
+                 case T18903.$wh ww1 of ww2 [Occ=Once1] { __DEFAULT ->
+                 GHC.Types.I# ww2
+                 }
+                 }}]
 h = \ (w :: Int) ->
-      case w of { GHC.Types.I# ww1 -> T18903.$wh ww1 }
+      case w of { GHC.Types.I# ww1 ->
+      case T18903.$wh ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
+      }
 
 
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a0802dce5c7e7249a0f8149d3eeec9a68defaf2

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a0802dce5c7e7249a0f8149d3eeec9a68defaf2
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/499e45c1/attachment-0001.html>


More information about the ghc-commits mailing list