diff options
Diffstat (limited to 'testsuite/tests/cpranal')
| -rw-r--r-- | testsuite/tests/cpranal/should_compile/T18174.hs | 92 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/should_compile/T18174.stderr | 254 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/should_compile/T18401.stderr | 36 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/should_compile/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/sigs/RecDataConCPR.hs | 117 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/sigs/RecDataConCPR.stderr | 26 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/sigs/RecDataConCPRa.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/sigs/RecDataConCPRa.hs-boot | 4 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/sigs/T19398.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/sigs/T19822.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/cpranal/sigs/all.T | 3 |
11 files changed, 522 insertions, 21 deletions
diff --git a/testsuite/tests/cpranal/should_compile/T18174.hs b/testsuite/tests/cpranal/should_compile/T18174.hs new file mode 100644 index 0000000000..bf1c02982c --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18174.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} +{-# LANGUAGE BangPatterns #-} + +module T18174 (fac1, fac2, fac3, facIO, dataConWrapper, strictField, thunkDiverges, h1, h2) where + +---------------------------------------------------------------------- +-- First some basic examples that we want to CPR nestedly for the Int. + +-- 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 would be fine to have CPR. +-- !1866 catches it, but Nested CPR light does not. +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') + +-- This one is like face2. +-- !1866 manages to unbox the Int, but Nested CPR does not. +facIO :: Int -> IO Int +facIO n | n < 2 = return 1 + | otherwise = do n' <- facIO (n-1); return (n*n') + +-- Now some checks wrt. strict fields where we don't want to unbox. + +data T = MkT Int !(Int, Int) + +-- | Should not unbox any component, because the wrapper of 'MkT' forces +-- 'p', which this function is lazy in. Similarly for 'x'. +dataConWrapper :: (Int, Int) -> Int -> (T, Int) +dataConWrapper p x = (MkT x p, x+1) +{-# NOINLINE dataConWrapper #-} + +-- | Should not unbox the second component, because 'x' won't be available +-- unboxed. It terminates, though. +strictField :: T -> (Int, (Int, Int)) +strictField (MkT x y) = (x, y) +{-# NOINLINE strictField #-} + +-- | Should not unbox the first component, because 'x' might not terminate. +thunkDiverges :: Int -> (Int, Bool) +thunkDiverges x = (let t = x+1 in t+t, False) + +---------------------------------------------------------------------- +-- The following functions are copied from T18894. This test is about +-- *exploiting* the demand signatures that we assertedly (by T18894) +-- annotate. + +g1 :: Int -> (Int,Int) +g1 1 = (15, 0) +g1 n = (2 * n, 2 `div` n) +{-# NOINLINE g1 #-} + +-- | Sadly, the @g1 2@ subexpression will be floated to top-level, where we +-- don't see the specific demand placed on it by @snd@. Tracked in #19001. +h1 :: Int -> Int +h1 1 = 0 +h1 2 = snd (g1 2) +h1 m = uncurry (+) (g1 m) + +-- | So @g2@ here takes an additional argument m that prohibits floating to +-- top-level. We want that argument to have the CPR property, so we have +-- to add a bang so that it's used strictly and ultimately unboxed. +-- We expect the following CPR type (in the form of !1866: +-- +-- > #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# #)@. +-- +-- Nested CPR light doesn't manage to unbox the second component, though. +g2 :: Int -> Int -> (Int,Int) +g2 !m 1 = (2 + m, 0) +g2 m n = (2 * m, 2 `div` n) +{-# NOINLINE g2 #-} + +-- !1866 manages to give it CPR, Nested CPR light doesn't. +h2 :: Int -> Int +h2 1 = 0 +h2 m + | odd m = snd (g2 m 2) + | otherwise = uncurry (+) (g2 2 m) diff --git a/testsuite/tests/cpranal/should_compile/T18174.stderr b/testsuite/tests/cpranal/should_compile/T18174.stderr new file mode 100644 index 0000000000..b251d9914a --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18174.stderr @@ -0,0 +1,254 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 464, types: 475, coercions: 6, joins: 0/3} + +-- RHS size: {terms: 8, types: 7, coercions: 0, joins: 0/0} +T18174.$WMkT :: Int %1 -> (Int, Int) %1 -> T +T18174.$WMkT = \ (conrep_aU0 :: Int) (conrep_aU1 :: (Int, Int)) -> case conrep_aU1 of conrep_X0 { __DEFAULT -> T18174.MkT conrep_aU0 conrep_X0 } + +-- RHS size: {terms: 5, types: 10, coercions: 0, joins: 0/0} +T18174.$wstrictField :: Int -> (Int, Int) -> (# Int, (Int, Int) #) +T18174.$wstrictField + = \ (ww_s18W :: Int) + (ww1_s18X + :: (Int, Int) + Unf=OtherCon []) -> + (# ww_s18W, ww1_s18X #) + +-- RHS size: {terms: 12, types: 21, coercions: 0, joins: 0/0} +strictField :: T -> (Int, (Int, Int)) +strictField = \ (ds_s18U :: T) -> case ds_s18U of { MkT ww_s18W ww1_s18X -> case T18174.$wstrictField ww_s18W ww1_s18X of { (# ww2_s1aJ, ww3_s1aK #) -> (ww2_s1aJ, ww3_s1aK) } } + +-- 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: 3, types: 1, coercions: 0, joins: 0/0} +$krep_r1c2 :: GHC.Types.KindRep +$krep_r1c2 = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep1_r1c3 :: [GHC.Types.KindRep] +$krep1_r1c3 = GHC.Types.: @GHC.Types.KindRep $krep_r1c2 (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep2_r1c4 :: [GHC.Types.KindRep] +$krep2_r1c4 = GHC.Types.: @GHC.Types.KindRep $krep_r1c2 $krep1_r1c3 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep3_r1c5 :: GHC.Types.KindRep +$krep3_r1c5 = GHC.Types.KindRepTyConApp GHC.Tuple.$tc(,) $krep2_r1c4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$tcT2 :: GHC.Prim.Addr# +T18174.$tcT2 = "T"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$tcT1 :: GHC.Types.TrName +T18174.$tcT1 = GHC.Types.TrNameS T18174.$tcT2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18174.$tcT :: GHC.Types.TyCon +T18174.$tcT = GHC.Types.TyCon 10767449832801551323## 11558512111670031614## T18174.$trModule T18174.$tcT1 0# GHC.Types.krep$* + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep4_r1c6 :: GHC.Types.KindRep +$krep4_r1c6 = GHC.Types.KindRepTyConApp T18174.$tcT (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep5_r1c7 :: GHC.Types.KindRep +$krep5_r1c7 = GHC.Types.KindRepFun $krep3_r1c5 $krep4_r1c6 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT1 :: GHC.Types.KindRep +T18174.$tc'MkT1 = GHC.Types.KindRepFun $krep_r1c2 $krep5_r1c7 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT3 :: GHC.Prim.Addr# +T18174.$tc'MkT3 = "'MkT"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT2 :: GHC.Types.TrName +T18174.$tc'MkT2 = GHC.Types.TrNameS T18174.$tc'MkT3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT :: GHC.Types.TyCon +T18174.$tc'MkT = GHC.Types.TyCon 15126196523434762667## 13148007393547580468## T18174.$trModule T18174.$tc'MkT2 0# T18174.$tc'MkT1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl_r1c8 :: Int +lvl_r1c8 = 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_s196) (ww_s199 :: GHC.Prim.Int#) (s_s19b :: a_s196) -> + case GHC.Prim.<# ww_s199 2# of { + __DEFAULT -> + let { + ds_s18k :: (a_s196, Int) + ds_s18k = case T18174.$wfac3 @a_s196 (GHC.Prim.-# ww_s199 1#) s_s19b of { (# ww1_s1aM, ww2_s1aN #) -> (ww1_s1aM, ww2_s1aN) } } in + (# case ds_s18k of { (s'_aYW, n'_aYX) -> s'_aYW }, case ds_s18k of { (s'_aYW, n'_aYX) -> case n'_aYX of { GHC.Types.I# ww1_s193 -> GHC.Types.I# (GHC.Prim.*# ww1_s193 ww1_s193) } } #); + 1# -> (# s_s19b, lvl_r1c8 #) + } +end Rec } + +-- RHS size: {terms: 14, types: 16, coercions: 0, joins: 0/0} +fac3 :: forall a. Int -> a -> (a, Int) +fac3 = \ (@a_s196) (n_s197 :: Int) (s_s19b :: a_s196) -> case n_s197 of { GHC.Types.I# ww_s199 -> case T18174.$wfac3 @a_s196 ww_s199 s_s19b of { (# ww1_s1aM, ww2_s1aN #) -> (ww1_s1aM, ww2_s1aN) } } + +Rec { +-- RHS size: {terms: 24, types: 21, coercions: 0, joins: 0/0} +T18174.$wfac2 :: forall {a}. GHC.Prim.Int# -> a -> (# a, Int #) +T18174.$wfac2 + = \ (@a_s19g) (ww_s19j :: GHC.Prim.Int#) (s_s19l :: a_s19g) -> + case GHC.Prim.<# ww_s19j 2# of { + __DEFAULT -> case T18174.$wfac2 @a_s19g (GHC.Prim.-# ww_s19j 1#) s_s19l of { (# ww1_s1aP, ww2_s1aQ #) -> (# ww1_s1aP, GHC.Num.$fNumInt_$c* ww2_s1aQ ww2_s1aQ #) }; + 1# -> (# s_s19l, lvl_r1c8 #) + } +end Rec } + +-- RHS size: {terms: 14, types: 16, coercions: 0, joins: 0/0} +fac2 :: forall a. Int -> a -> (a, Int) +fac2 = \ (@a_s19g) (n_s19h :: Int) (s_s19l :: a_s19g) -> case n_s19h of { GHC.Types.I# ww_s19j -> case T18174.$wfac2 @a_s19g ww_s19j s_s19l of { (# ww1_s1aP, ww2_s1aQ #) -> (ww1_s1aP, ww2_s1aQ) } } + +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_s19q) (ww_s19t :: GHC.Prim.Int#) (s_s19v :: a_s19q) -> + case GHC.Prim.<# ww_s19t 2# of { + __DEFAULT -> case T18174.$wfac1 @a_s19q (GHC.Prim.-# ww_s19t 1#) s_s19v of { (# ww1_s19y, ww2_s1aS #) -> (# ww1_s19y, GHC.Prim.*# ww_s19t ww2_s1aS #) }; + 1# -> (# s_s19v, 1# #) + } +end Rec } + +-- RHS size: {terms: 15, types: 16, coercions: 0, joins: 0/0} +fac1 :: forall a. Int -> a -> (a, Int) +fac1 = \ (@a_s19q) (n_s19r :: Int) (s_s19v :: a_s19q) -> case n_s19r of { GHC.Types.I# ww_s19t -> case T18174.$wfac1 @a_s19q ww_s19t s_s19v of { (# ww1_s19y, ww2_s1aS #) -> (ww1_s19y, GHC.Types.I# ww2_s1aS) } } + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.h5 :: Int +T18174.h5 = GHC.Types.I# 0# + +-- RHS size: {terms: 37, types: 15, coercions: 0, joins: 0/1} +T18174.$wg2 :: GHC.Prim.Int# -> GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) +T18174.$wg2 + = \ (ww_s19G :: GHC.Prim.Int#) (ww1_s19K :: GHC.Prim.Int#) -> + case ww1_s19K of ds_X2 { + __DEFAULT -> + (# GHC.Prim.*# 2# ww_s19G, + case ds_X2 of wild_X3 { + __DEFAULT -> + let { + c1#_a17n :: GHC.Prim.Int# + c1#_a17n = GHC.Prim.andI# 1# (GHC.Prim.<# wild_X3 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#_a17n) wild_X3 of wild1_a17o { __DEFAULT -> GHC.Types.I# (GHC.Prim.-# wild1_a17o c1#_a17n) }; + 0# -> GHC.Real.divZeroError @Int + } #); + 1# -> (# GHC.Prim.+# 2# ww_s19G, T18174.h5 #) + } + +-- RHS size: {terms: 30, types: 19, coercions: 0, joins: 0/0} +T18174.$wh2 :: GHC.Prim.Int# -> Int +T18174.$wh2 + = \ (ww_s19W :: GHC.Prim.Int#) -> + case ww_s19W of ds_X2 { + __DEFAULT -> + case GHC.Prim.remInt# ds_X2 2# of { + __DEFAULT -> case T18174.$wg2 ds_X2 2# of { (# ww1_s1aU, ww2_s19Q #) -> ww2_s19Q }; + 0# -> case T18174.$wg2 2# ds_X2 of { (# ww1_s1aU, ww2_s19Q #) -> case ww2_s19Q of { GHC.Types.I# y_a17v -> GHC.Types.I# (GHC.Prim.+# ww1_s1aU y_a17v) } } + }; + 1# -> T18174.h5 + } + +-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +h2 :: Int -> Int +h2 = \ (ds_s19U :: Int) -> case ds_s19U of { GHC.Types.I# ww_s19W -> T18174.$wh2 ww_s19W } + +-- RHS size: {terms: 34, types: 14, coercions: 0, joins: 0/1} +T18174.$wg1 :: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) +T18174.$wg1 + = \ (ww_s1a3 :: GHC.Prim.Int#) -> + case ww_s1a3 of ds_X2 { + __DEFAULT -> + (# GHC.Prim.*# 2# ds_X2, + case ds_X2 of wild_X3 { + __DEFAULT -> + let { + c1#_a17n :: GHC.Prim.Int# + c1#_a17n = GHC.Prim.andI# 1# (GHC.Prim.<# wild_X3 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#_a17n) wild_X3 of wild1_a17o { __DEFAULT -> GHC.Types.I# (GHC.Prim.-# wild1_a17o c1#_a17n) }; + 0# -> GHC.Real.divZeroError @Int + } #); + 1# -> (# 15#, T18174.h5 #) + } + +-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} +T18174.h4 :: (Int, Int) +T18174.h4 = case T18174.$wg1 2# of { (# ww_s1aW, ww1_s1a9 #) -> (GHC.Types.I# ww_s1aW, ww1_s1a9) } + +-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0} +T18174.$wh1 :: GHC.Prim.Int# -> Int +T18174.$wh1 + = \ (ww_s1af :: GHC.Prim.Int#) -> + case ww_s1af of ds_X2 { + __DEFAULT -> case T18174.$wg1 ds_X2 of { (# ww1_s1aW, ww2_s1a9 #) -> case ww2_s1a9 of { GHC.Types.I# y_a17v -> GHC.Types.I# (GHC.Prim.+# ww1_s1aW y_a17v) } }; + 1# -> T18174.h5; + 2# -> case T18174.h4 of { (ds1_a155, y_a156) -> y_a156 } + } + +-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +h1 :: Int -> Int +h1 = \ (ds_s1ad :: Int) -> case ds_s1ad of { GHC.Types.I# ww_s1af -> T18174.$wh1 ww_s1af } + +-- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} +thunkDiverges :: Int -> (Int, Bool) +thunkDiverges = \ (x_aIy :: Int) -> (case x_aIy of { GHC.Types.I# x1_a17s -> GHC.Types.I# (GHC.Prim.+# 2# (GHC.Prim.*# 2# x1_a17s)) }, GHC.Types.False) + +-- RHS size: {terms: 13, types: 10, coercions: 0, joins: 0/0} +T18174.$wdataConWrapper :: (Int, Int) -> Int -> (# T, Int #) +T18174.$wdataConWrapper = \ (p_s1av :: (Int, Int)) (x_s1aw :: Int) -> (# T18174.$WMkT x_s1aw p_s1av, case x_s1aw of { GHC.Types.I# x1_a17s -> GHC.Types.I# (GHC.Prim.+# x1_a17s 1#) } #) + +-- RHS size: {terms: 10, types: 13, coercions: 0, joins: 0/0} +dataConWrapper :: (Int, Int) -> Int -> (T, Int) +dataConWrapper = \ (p_s1av :: (Int, Int)) (x_s1aw :: Int) -> case T18174.$wdataConWrapper p_s1av x_s1aw of { (# ww_s1aY, ww1_s1aZ #) -> (ww_s1aY, ww1_s1aZ) } + +Rec { +-- RHS size: {terms: 27, types: 31, coercions: 0, joins: 0/0} +T18174.$wfacIO :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) +T18174.$wfacIO + = \ (ww_s1aD :: GHC.Prim.Int#) (eta_s1aF :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case GHC.Prim.<# ww_s1aD 2# of { + __DEFAULT -> case T18174.$wfacIO (GHC.Prim.-# ww_s1aD 1#) eta_s1aF of { (# ipv_a180, ipv1_a181 #) -> (# ipv_a180, case ipv1_a181 of { GHC.Types.I# y_a16I -> GHC.Types.I# (GHC.Prim.*# ww_s1aD y_a16I) } #) }; + 1# -> (# eta_s1aF, lvl_r1c8 #) + } +end Rec } + +-- RHS size: {terms: 8, types: 5, coercions: 0, joins: 0/0} +T18174.facIO1 :: Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) +T18174.facIO1 = \ (n_s1aB :: Int) (eta_s1aF :: GHC.Prim.State# GHC.Prim.RealWorld) -> case n_s1aB of { GHC.Types.I# ww_s1aD -> T18174.$wfacIO ww_s1aD eta_s1aF } + +-- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0} +facIO :: Int -> IO Int +facIO = T18174.facIO1 `cast` (<Int>_R %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) + + + diff --git a/testsuite/tests/cpranal/should_compile/T18401.stderr b/testsuite/tests/cpranal/should_compile/T18401.stderr index e299ba4dc7..75913b3979 100644 --- a/testsuite/tests/cpranal/should_compile/T18401.stderr +++ b/testsuite/tests/cpranal/should_compile/T18401.stderr @@ -1,34 +1,34 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 54, types: 101, coercions: 0, joins: 0/0} +Result size of Tidy Core = {terms: 52, types: 86, coercions: 0, joins: 0/0} Rec { --- RHS size: {terms: 20, types: 31, coercions: 0, joins: 0/0} -T18401.safeInit_$spoly_$wgo1 :: forall {a}. a -> [a] -> (# Bool, [a] #) -T18401.safeInit_$spoly_$wgo1 - = \ (@a_aO1) (sc_s17W :: a_aO1) (sc1_s17V :: [a_aO1]) -> - case sc1_s17V of { - [] -> (# GHC.Types.True, GHC.Types.[] @a_aO1 #); - : y_a158 ys_a159 -> (# GHC.Types.True, GHC.Types.: @a_aO1 sc_s17W (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_s17y, ww1_s17z #) -> ww1_s17z }) #) +-- RHS size: {terms: 18, types: 24, coercions: 0, joins: 0/0} +T18401.$w$spoly_$wgo1 :: forall {a}. a -> [a] -> (# [a] #) +T18401.$w$spoly_$wgo1 + = \ (@a_s18C) (w_s18D :: a_s18C) (w1_s18E :: [a_s18C]) -> + case w1_s18E of { + [] -> (# GHC.Types.[] @a_s18C #); + : y_a15b ys_a15c -> (# GHC.Types.: @a_s18C w_s18D (case T18401.$w$spoly_$wgo1 @a_s18C y_a15b ys_a15c of { (# ww_s18J #) -> ww_s18J }) #) } end Rec } --- RHS size: {terms: 17, types: 25, coercions: 0, joins: 0/0} +-- RHS size: {terms: 17, types: 22, coercions: 0, joins: 0/0} si :: forall a. [a] -> (Bool, [a]) si - = \ (@a_s17i) (w_s17j :: [a_s17i]) -> - case w_s17j of { - [] -> (GHC.Types.False, GHC.Types.[] @a_s17i); - : y_a158 ys_a159 -> (GHC.Types.True, case T18401.safeInit_$spoly_$wgo1 @a_s17i y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 }) + = \ (@a_s17T) (w_s17U :: [a_s17T]) -> + case w_s17U of { + [] -> (GHC.Types.False, GHC.Types.[] @a_s17T); + : y_a15b ys_a15c -> (GHC.Types.True, case T18401.$w$spoly_$wgo1 @a_s17T y_a15b ys_a15c of { (# ww_s18J #) -> ww_s18J }) } --- RHS size: {terms: 14, types: 22, coercions: 0, joins: 0/0} +-- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0} safeInit :: forall a. [a] -> Maybe [a] safeInit - = \ (@a_aO1) (xs_aus :: [a_aO1]) -> - case xs_aus of { - [] -> GHC.Maybe.Nothing @[a_aO1]; - : y_a158 ys_a159 -> GHC.Maybe.Just @[a_aO1] (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 }) + = \ (@a_aPB) (xs_aut :: [a_aPB]) -> + case xs_aut of { + [] -> GHC.Maybe.Nothing @[a_aPB]; + : y_a15b ys_a15c -> GHC.Maybe.Just @[a_aPB] (case T18401.$w$spoly_$wgo1 @a_aPB y_a15b ys_a15c of { (# ww_s18J #) -> ww_s18J }) } diff --git a/testsuite/tests/cpranal/should_compile/all.T b/testsuite/tests/cpranal/should_compile/all.T index d70d978be6..570b78228f 100644 --- a/testsuite/tests/cpranal/should_compile/all.T +++ b/testsuite/tests/cpranal/should_compile/all.T @@ -7,6 +7,7 @@ setTestOpts(f) test('Cpr001', [], multimod_compile, ['Cpr001', '-v0']) # The following tests grep for type signatures of worker functions. test('T18109', [ grep_errmsg(r'^T18109\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999']) +test('T18174', [ grep_errmsg(r'^T18174\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999']) # T18401 probably needs -flate-dmd-anal so that it runs after SpecConstr. # It is currently broken, but not marked expect_broken. We can't know the exact # name of the function before it is fixed, so expect_broken doesn't make sense. diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPR.hs b/testsuite/tests/cpranal/sigs/RecDataConCPR.hs new file mode 100644 index 0000000000..c26ae1264f --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPR.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Serves as a unit test for isRecDataCon. +-- See Note [CPR for recursive data constructors] for similar examples. +module RecDataConCPR where + +import Control.Monad.Trans.State +import Control.Monad.ST +import Data.Char + +import {-# SOURCE #-} RecDataConCPRa + +replicateOne :: Int -> [Int] +replicateOne 1 = [1] +replicateOne n = 1 : replicateOne (n-1) + +data T = T (Int, (Bool, Char)) -- NonRec +t :: Char -> Bool -> Int -> T +t a b c = T (c, (b, a)) + +data U = U [Int] -- NonRec + +u :: Int -> U +u x = U (replicate x 1000) + +data U2 = U2 [U2] -- Rec + +u2 :: Int -> U2 +u2 x = U2 (replicate 1000 (u2 (x-1))) + +data R0 = R0 R1 | R0End Int -- Rec, but out of fuel (and thus considered NonRec) +data R1 = R1 R2 +data R2 = R2 R3 +data R3 = R3 R4 +data R4 = R4 R5 +data R5 = R5 R6 +data R6 = R6 R7 +data R7 = R7 R8 +data R8 = R8 R9 +data R9 = R9 R0 + +r :: Bool -> Int -> R0 +r False x = r True x +r True x = R0 (R1 (R2 (R3 (R4 (R5 (R6 (R7 (R8 (R9 (R0End x)))))))))) + +data R20 = R20 R21 | R20End Int -- Rec +data R21 = R21 R20 + +r2 :: Bool -> Int -> R20 +r2 False x = r2 True x +r2 True x = R20 (R21 (R20End 4)) + +newtype Fix f = Fix (f (Fix f)) -- Rec + +fixx :: Int -> Fix Maybe +fixx 0 = Fix Nothing +fixx n = Fix (Just (fixx (n-1))) + +data N = N (Fix (Either Int)) -- NonRec +data M = M (Fix (Either M)) -- Rec + +n :: Int -> N +n = N . go + where + go 0 = Fix (Left 42) + go n = Fix (Right (go (n-1))) + +m :: Int -> M +m = M . go + where + go 0 = Fix (Left (m 42)) + go n = Fix (Right (go (n-1))) + +data F = F (F -> Int) -- NonRec +f :: Int -> F +f n = F (const n) + +data G = G (Int -> G) -- NonRec +g :: Int -> G +g n = G (\m -> g (n+m)) + +newtype MyM s a = MyM (StateT Int (ST s) a) -- NonRec +myM :: Int -> MyM s Int +myM 0 = MyM $ pure 42 +myM n = myM (n-1) + +type S = (Int, Bool) -- NonRec +s :: Int -> S +s n = (n, True) + +type family E a +type instance E Int = Char +type instance E (a,b) = (E a, E b) +type instance E Char = Blub +data Blah = Blah (E (Int, (Int, Int))) -- NonRec +data Blub = Blub (E (Char, Int)) -- Rec +data Blub2 = Blub2 (E (Bool, Int)) -- Rec, because stuck + +blah :: Int -> Blah +blah n = Blah (chr n, (chr (n+1), chr (n+2))) + +blub :: Int -> Blub +blub n = Blub (blub (n-1), chr n) + +blub2 :: Int -> Blub2 +blub2 n = Blub2 (undefined :: E Bool, chr n) + +-- Now for abstract TyCons, point (7) of the Note: +data BootNonRec1 = BootNonRec1 BootNonRec2 -- in RecDataConCPRa.hs-boot +data BootRec1 = BootRec1 BootRec2 -- in RecDataConCPRa.hs-boot, recurses back + +bootNonRec :: Int -> BootNonRec2 -> BootNonRec1 -- Nothing, thus like NonRec +bootNonRec x b2 = BootNonRec1 b2 + +bootRec :: Int -> BootRec2 -> BootRec1 -- Nothing, thus like NonRec +bootRec x b2 = BootRec1 b2 diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr b/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr new file mode 100644 index 0000000000..b330c78da0 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr @@ -0,0 +1,26 @@ + +==================== Cpr signatures ==================== +RecDataConCPR.blah: 1(1(, 1)) +RecDataConCPR.blub: +RecDataConCPR.blub2: +RecDataConCPR.bootNonRec: 1 +RecDataConCPR.bootRec: 1 +RecDataConCPR.f: 1 +RecDataConCPR.fixx: +RecDataConCPR.g: 1 +RecDataConCPR.m: +RecDataConCPR.myM: 1(, 1(1,)) +RecDataConCPR.n: 1 +RecDataConCPR.r: 1(1(1(1(1(1(1(1(1(1(2)))))))))) +RecDataConCPR.r2: +RecDataConCPR.replicateOne: +RecDataConCPR.s: 1(, 2) +RecDataConCPR.t: 1(1(, 1)) +RecDataConCPR.u: 1 +RecDataConCPR.u2: + + + +==================== Cpr signatures ==================== + + diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs new file mode 100644 index 0000000000..0ebdeb8c53 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs @@ -0,0 +1,6 @@ +module RecDataConCPRa where + +import RecDataConCPR + +data BootNonRec2 = BootNonRec2 +data BootRec2 = BootRec2 BootRec1 diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs-boot b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs-boot new file mode 100644 index 0000000000..35369d1ef6 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs-boot @@ -0,0 +1,4 @@ +module RecDataConCPRa where + +data BootNonRec2 +data BootRec2 diff --git a/testsuite/tests/cpranal/sigs/T19398.stderr b/testsuite/tests/cpranal/sigs/T19398.stderr index a293fdd089..faa335d399 100644 --- a/testsuite/tests/cpranal/sigs/T19398.stderr +++ b/testsuite/tests/cpranal/sigs/T19398.stderr @@ -3,6 +3,6 @@ T19398.a: T19398.c: T19398.f: 1 -T19398.g: 1 +T19398.g: 1(1, 1) diff --git a/testsuite/tests/cpranal/sigs/T19822.stderr b/testsuite/tests/cpranal/sigs/T19822.stderr index 8e4636d322..607e806e8c 100644 --- a/testsuite/tests/cpranal/sigs/T19822.stderr +++ b/testsuite/tests/cpranal/sigs/T19822.stderr @@ -1,5 +1,5 @@ ==================== Cpr signatures ==================== -T19822.singleton: 1 +T19822.singleton: 1(, 1) diff --git a/testsuite/tests/cpranal/sigs/all.T b/testsuite/tests/cpranal/sigs/all.T index 99cdebe716..90a6b9e693 100644 --- a/testsuite/tests/cpranal/sigs/all.T +++ b/testsuite/tests/cpranal/sigs/all.T @@ -3,9 +3,10 @@ setTestOpts(only_ways(['optasm'])) # This directory contains tests where we annotate functions with expected # CPR signatures, and verify that these are actually those found by the compiler -setTestOpts(extra_hc_opts('-dno-typeable-binds -ddump-cpr-signatures')) +setTestOpts(extra_hc_opts('-dno-typeable-binds -ddump-cpr-signatures -v0')) test('CaseBinderCPR', normal, compile, ['']) +test('RecDataConCPR', [], multimod_compile, ['RecDataConCPR', '']) test('T19232', normal, compile, ['']) test('T19398', normal, compile, ['']) test('T19822', normal, compile, ['']) |