diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 6471c62efc8a5185af9d4873fdf88236146be9f3..496a910107563d835f98fe85b6f512506fcdae64 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -513,8 +513,11 @@ this transformation. So we try to limit it as much as possible: Of course both (1) and (2) are readily defeated by disguising the bottoms. -4. Note [Newtype arity] -~~~~~~~~~~~~~~~~~~~~~~~~ +There also is an interaction with Note [Combining arity type with demand info], +outlined in Wrinkle (CAD1). + +Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~ Non-recursive newtypes are transparent, and should not get in the way. We do (currently) eta-expand recursive newtypes too. So if we have, say @@ -716,7 +719,7 @@ So safeArityType will trim it to (AT [C?, C?] Top), whose [ATLamInfo] now reflects the (cost-free) arity of the expression Why do we ever need an "unsafe" ArityType, such as the example above? -Because its (cost-free) arity may increased by combineWithDemandOneShots +Because its (cost-free) arity may increased by combineWithCallCards in findRhsArity. See Note [Combining arity type with demand info]. Thus the function `arityType` returns a regular "unsafe" ArityType, that @@ -918,14 +921,14 @@ findRhsArity opts is_rec bndr rhs NonRecursive -> trimArityType ty_arity (cheapArityType rhs) ty_arity = typeArity (idType bndr) - id_one_shots = idDemandOneShots bndr + use_call_cards = useSiteCallCards bndr step :: ArityEnv -> SafeArityType step env = trimArityType ty_arity $ safeArityType $ -- See Note [Arity invariants for bindings], item (3) - arityType env rhs `combineWithDemandOneShots` id_one_shots + combineWithCallCards env (arityType env rhs) use_call_cards -- trimArityType: see Note [Trim arity inside the loop] - -- combineWithDemandOneShots: take account of the demand on the + -- combineWithCallCards: take account of the demand on the -- binder. Perhaps it is always called with 2 args -- let f = \x. blah in (f 3 4, f 1 9) -- f's demand-info says how many args it is called with @@ -950,14 +953,24 @@ findRhsArity opts is_rec bndr rhs where next_at = step (extendSigEnv init_env bndr cur_at) -infixl 2 `combineWithDemandOneShots` - -combineWithDemandOneShots :: ArityType -> [OneShotInfo] -> ArityType +combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType -- See Note [Combining arity type with demand info] -combineWithDemandOneShots at@(AT lams div) oss +combineWithCallCards env at@(AT lams div) cards | null lams = at | otherwise = AT (zip_lams lams oss) div where + oss = map card_to_oneshot cards + card_to_oneshot n + | isAtMostOnce n, not (pedanticBottoms env) + -- Take care for -fpedantic-bottoms; + -- see Note [Combining arity type with demand info], Wrinkle (CAD1) + = OneShotLam + | n == C_11 + -- Safe to eta-expand even in the presence of -fpedantic-bottoms + -- see Note [Combining arity type with demand info], Wrinkle (CAD1) + = OneShotLam + | otherwise + = NoOneShotInfo zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] zip_lams lams [] = lams zip_lams [] oss | isDeadEndDiv div = [] @@ -966,29 +979,33 @@ combineWithDemandOneShots at@(AT lams div) oss zip_lams ((ch,os1):lams) (os2:oss) = (ch, os1 `bestOneShot` os2) : zip_lams lams oss -idDemandOneShots :: Id -> [OneShotInfo] -idDemandOneShots bndr - = call_arity_one_shots `zip_lams` dmd_one_shots +useSiteCallCards :: Id -> [Card] +useSiteCallCards bndr + = call_arity_one_shots `zip_cards` dmd_one_shots where - call_arity_one_shots :: [OneShotInfo] + call_arity_one_shots :: [Card] call_arity_one_shots | call_arity == 0 = [] - | otherwise = NoOneShotInfo : replicate (call_arity-1) OneShotLam - -- Call Arity analysis says the function is always called - -- applied to this many arguments. The first NoOneShotInfo is because - -- if Call Arity says "always applied to 3 args" then the one-shot info - -- we get is [NoOneShotInfo, OneShotLam, OneShotLam] + | otherwise = C_0N : replicate (call_arity-1) C_01 + -- Call Arity analysis says /however often the function is called/, it is + -- always applied to this many arguments. + -- The first C_0N is because of the "however often it is called" part. + -- Thus if Call Arity says "always applied to 3 args" then the one-shot info + -- we get is [C_0N, C_01, C_01] call_arity = idCallArity bndr - dmd_one_shots :: [OneShotInfo] + dmd_one_shots :: [Card] -- If the demand info is C(x,C(1,C(1,.))) then we know that an -- application to one arg is also an application to three - dmd_one_shots = argOneShots (idDemandInfo bndr) + dmd_one_shots = case idDemandInfo bndr of + AbsDmd -> [] -- There is no use in eta expanding + BotDmd -> [] -- when the binding could be dropped instead + _ :* sd -> callCards sd -- Take the *longer* list - zip_lams (lam1:lams1) (lam2:lams2) = (lam1 `bestOneShot` lam2) : zip_lams lams1 lams2 - zip_lams [] lams2 = lams2 - zip_lams lams1 [] = lams1 + zip_cards (n1:ns1) (n2:ns2) = (n1 `glbCard` n2) : zip_cards ns1 ns2 + zip_cards [] ns2 = ns2 + zip_cards ns1 [] = ns1 {- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1084,7 +1101,7 @@ Combining these two pieces of info, we can get the final ArityType result: arity=3, which is better than we could do from either source alone. -The "combining" part is done by combineWithDemandOneShots. It +The "combining" part is done by combineWithCallCards. It uses info from both Call Arity and demand analysis. We may have /more/ call demands from the calls than we have lambdas @@ -1103,6 +1120,22 @@ Now we don't want to eta-expand f1 to have 3 args; only two. Nor, in the case of f2, do we want to push that error call under a lambda. Hence the takeWhile in combineWithDemandDoneShots. +Wrinkles: + +(CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms + (See Note [Dealing with bottom]). Consider + + let f = \x y. error "blah" in + f 2 1 `seq` Just (f 3 2 1) + -- Demand on f is C(x,C(1,C(M,L))) + + Usually, it is OK to consider a lambda that is called *at most* once (so call + cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it. + But with -fpedantic-bottoms that is no longer true: If we were to eta-expand + f to arity 3, we'd discard the error raised when evaluating `f 2 1`. + Hence in the presence of -fpedantic-bottoms, we must have C_11 for + eta-expansion. + Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Similarly to CPR (see Note [Don't w/w join points for CPR] in diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 38dad20c0a634ad3c4abef3f74c561fb5c93bcc0..3655f0ac904e1f69a07500a700bbab8a65f3cc81 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2190,7 +2190,7 @@ occ_anal_lam_tail env expr@(Lam {}) -- Use updOneShotInfo, not setOneShotInfo, as pre-existing -- one-shot info might be better than what we can infer, e.g. -- due to explicit use of the magic 'oneShot' function. - -- See Note [The oneShot function] + -- See Note [oneShot magic] env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' } in go env' (bndr':rev_bndrs) body diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 93fe11a65d8f0eb8cafb7fee38c8653c4dc9cc32..de4fcbdc265862bf7f2c9529c1a6315fb0080fb7 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -430,7 +430,7 @@ We keep the OneShotInfo because we want it to propagate into the interface. Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we -must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make. +must preserve this info in inlinings. See Note [oneShot magic] in GHC.Types.Id.Make. This applies to lambda binders only, hence it is stored in IfaceLamBndr. -} diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index a61e3d2d0bfa2ad716bd2028ef750fbe13ec00a0..8bf475222e4f5e89002f80360cb7d59b1c151b76 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -41,7 +41,7 @@ import GHC.Types.Basic ( Arity, TypeOrConstraint(..) ) import GHC.Types.Literal import GHC.Types.ForeignCall import GHC.Types.IPE -import GHC.Types.Demand ( isUsedOnceDmd ) +import GHC.Types.Demand ( isAtMostOnceDmd ) import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Unit.Module @@ -746,8 +746,8 @@ mkTopStgRhs CoreToStgOpts where (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs - upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable + upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable -- CAF cost centres generated for -fcaf-all caf_cc = mkAutoCC bndr modl @@ -792,8 +792,8 @@ mkStgRhs bndr (PreStgRhs bndrs rhs typ) where (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs - upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable + upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable {- SDM: disabled. Eval/Apply can't handle functions with arity zero very diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 1cc626358c58795a1fae841eb6e29357c673db0c..1973433bd4e199e00c8b62e958d7563002868c16 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -134,7 +134,7 @@ ifaceBndrType (IfaceTvBndr (_, t)) = t type IfaceLamBndr = (IfaceBndr, IfaceOneShot) data IfaceOneShot -- See Note [Preserve OneShotInfo] in "GHC.Core.Tidy" - = IfaceNoOneShot -- and Note [The oneShot function] in "GHC.Types.Id.Make" + = IfaceNoOneShot -- and Note [oneShot magic] in "GHC.Types.Id.Make" | IfaceOneShot instance Outputable IfaceOneShot where diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 3dbf84a5766714d720cadee7bbab2c5513a2d85c..f9ec6a600747ee5b12712bab515890bcceac791f 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -478,9 +478,9 @@ closureGrowth expander sizer group abs_ids = go -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of -- 'rhsCard' and accurately captures the cardinality of the RHSs body -- relative to its defining context. - | isAbs n = 0 - | cg <= 0 = if isStrict n then cg else 0 - | isUsedOnce n = cg - | otherwise = infinity + | isAbs n = 0 + | cg <= 0 = if isStrict n then cg else 0 + | isAtMostOnce n = cg + | otherwise = infinity where cg = go body diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 26aed41e0a368086b8e68d5a63bafd2b00c12c61..aeaf3b4cd4a6cbac423703c1c5f14584719bfe1c 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -22,13 +22,15 @@ module GHC.Types.Demand ( absDmd, topDmd, botDmd, seqDmd, topSubDmd, -- *** Least upper bound lubCard, lubDmd, lubSubDmd, + -- *** Greatest lower bound + glbCard, -- *** Plus plusCard, plusDmd, plusSubDmd, -- *** Multiply multCard, multDmd, multSubDmd, -- ** Predicates on @Card@inalities and @Demand@s - isAbs, isUsedOnce, isStrict, - isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd, + isAbs, isAtMostOnce, isStrict, + isAbsDmd, isAtMostOnceDmd, isStrUsedDmd, isStrictDmd, isTopDmd, isWeakDmd, onlyBoxedArguments, -- ** Special demands evalDmd, @@ -39,7 +41,7 @@ module GHC.Types.Demand ( peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, mkWorkerDemand, subDemandIfEvaluated, -- ** Extracting one-shot information - argOneShots, argsOneShots, saturatedByOneShots, + callCards, argOneShots, argsOneShots, saturatedByOneShots, -- ** Manipulating Boxity of a Demand unboxDeeplyDmd, @@ -540,9 +542,9 @@ isAbs :: Card -> Bool isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set -- | True <=> upper bound is 1. -isUsedOnce :: Card -> Bool +isAtMostOnce :: Card -> Bool -- See Note [Bit vector representation for Card] -isUsedOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set +isAtMostOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set -- | Is this a 'CardNonAbs'? isCardNonAbs :: Card -> Bool @@ -550,7 +552,7 @@ isCardNonAbs = not . isAbs -- | Is this a 'CardNonOnce'? isCardNonOnce :: Card -> Bool -isCardNonOnce n = isAbs n || not (isUsedOnce n) +isCardNonOnce n = isAbs n || not (isAtMostOnce n) -- | Intersect with [0,1]. oneifyCard :: Card -> Card @@ -927,8 +929,8 @@ isStrUsedDmd :: Demand -> Bool isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) -- | Is the value used at most once? -isUsedOnceDmd :: Demand -> Bool -isUsedOnceDmd (n :* _) = isUsedOnce n +isAtMostOnceDmd :: Demand -> Bool +isAtMostOnceDmd (n :* _) = isAtMostOnce n -- | We try to avoid tracking weak free variable demands in strictness -- signatures for analysis performance reasons. @@ -1068,12 +1070,16 @@ argOneShots :: Demand -- ^ depending on saturation argOneShots AbsDmd = [] -- This defn conflicts with 'saturatedByOneShots', argOneShots BotDmd = [] -- according to which we should return -- @repeat OneShotLam@ here... -argOneShots (_ :* sd) = go sd +argOneShots (_ :* sd) = map go (callCards sd) where - go (Call n sd) - | isUsedOnce n = OneShotLam : go sd - | otherwise = NoOneShotInfo : go sd - go _ = [] + go n | isAtMostOnce n = OneShotLam + | otherwise = NoOneShotInfo + +-- | See Note [Computing one-shot info] +callCards :: SubDemand -> [Card] +callCards (Call n sd) = n : callCards sd +callCards (Poly _ _n) = [] -- n is never C_01 or C_11 so we may as well stop here +callCards Prod{} = [] -- | -- @saturatedByOneShots n C(M,C(M,...)) = True@ @@ -1083,7 +1089,7 @@ argOneShots (_ :* sd) = go sd saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots _ AbsDmd = True saturatedByOneShots _ BotDmd = True -saturatedByOneShots n (_ :* sd) = isUsedOnce $ fst $ peelManyCalls n sd +saturatedByOneShots n (_ :* sd) = isAtMostOnce $ fst $ peelManyCalls n sd {- Note [Strict demands] ~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 6969bfb091d9561fd0eea1de0325fb89a219f16f..5581852ef3343b36a91b734a75e0ae5681958bb7 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -1939,7 +1939,7 @@ nospecId = pcMiscPrelId nospecIdName ty info info = noCafIdInfo ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) -oneShotId :: Id -- See Note [The oneShot function] +oneShotId :: Id -- See Note [oneShot magic] oneShotId = pcRepPolyId oneShotName ty concs info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma @@ -2238,7 +2238,7 @@ This is crucial: otherwise, we could import an unfolding in which * To defeat the specialiser when we have incoherent instances. See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv. -Note [The oneShot function] +Note [oneShot magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 and Note [Left folds via right fold]) it was determined that it would be useful @@ -2263,12 +2263,18 @@ after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get --> \x[oneshot] e[x/y] which is what we want. -It is only effective if the one-shot info survives as long as possible; in -particular it must make it into the interface in unfoldings. See Note [Preserve -OneShotInfo] in GHC.Core.Tidy. - Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. +Wrinkles: +(OS1) It is only effective if the one-shot info survives as long as possible; in + particular it must make it into the interface in unfoldings. See Note [Preserve + OneShotInfo] in GHC.Core.Tidy. + +(OS2) (oneShot (error "urk")) rewrites to + \x[oneshot]. error "urk" x + thereby hiding the `error` under a lambda, which might be surprising, + particularly if you have `-fpedantic-bottoms` on. See #24296. + ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}. If things get diff --git a/testsuite/tests/arityanal/should_compile/T21755.stderr b/testsuite/tests/arityanal/should_compile/T21755.stderr index 0519ecba6ea913e21689ec692e81e9e4973fbf73..95933b309f396b9837f7c299d872ef38e338c8b6 100644 --- a/testsuite/tests/arityanal/should_compile/T21755.stderr +++ b/testsuite/tests/arityanal/should_compile/T21755.stderr @@ -1 +1,27 @@ - \ No newline at end of file + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 36, types: 25, coercions: 0, joins: 0/0} + +Rec { +-- RHS size: {terms: 12, types: 8, coercions: 0, joins: 0/0} +mySum [Occ=LoopBreaker] :: [Int] -> Int +[GblId, Arity=1, Unf=OtherCon []] +mySum + = \ (ds :: [Int]) -> + case ds of { + [] -> GHC.Types.I# 0#; + : x xs -> + @Int GHC.Num.$fNumInt x (mySum xs) + } +end Rec } + +-- RHS size: {terms: 22, types: 9, coercions: 0, joins: 0/0} +f :: Int -> (Int -> Int) -> Int -> Int +[GblId, Arity=2, Unf=OtherCon []] +f = \ (k :: Int) (z :: Int -> Int) -> + case even @Int GHC.Real.$fIntegralInt (mySum (enumFromTo @Int GHC.Enum.$fEnumInt (GHC.Types.I# 0#) k)) of { + False -> \ (n :: Int) -> z n; + True -> \ (n :: Int) -> + @Int GHC.Num.$fNumInt n (GHC.Types.I# 1#) + } + + + diff --git a/testsuite/tests/arityanal/should_compile/T24296b.hs b/testsuite/tests/arityanal/should_compile/T24296b.hs new file mode 100644 index 0000000000000000000000000000000000000000..31ccab94bfc8fd12326b1e95fc41ed56b6ef40bc --- /dev/null +++ b/testsuite/tests/arityanal/should_compile/T24296b.hs @@ -0,0 +1,12 @@ +-- a bit simpler than T24296 +module T24296b (r) where + +f :: Int -> Int -> Int +f x = error "blah" + +g :: (Int -> Int -> Int) -> (Int -> Int -> Int) +g f = f +{-# OPAQUE g #-} + +r x y = g f y `seq` Just (g f x y) +{-# OPAQUE r #-} diff --git a/testsuite/tests/arityanal/should_compile/T24296b.stderr b/testsuite/tests/arityanal/should_compile/T24296b.stderr new file mode 100644 index 0000000000000000000000000000000000000000..cd8ba136ee3a9c84ff45ed5dd1ba7425f0f2723c --- /dev/null +++ b/testsuite/tests/arityanal/should_compile/T24296b.stderr @@ -0,0 +1,26 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 43, types: 29, coercions: 4, joins: 0/0} + +-- RHS size: {terms: 2, types: 3, coercions: 0, joins: 0/0} +g :: (Int -> Int -> Int) -> Int -> Int -> Int +[GblId, Arity=1, Unf=OtherCon []] +g = \ (f1 :: Int -> Int -> Int) -> f1 + +-- RHS size: {terms: 20, types: 3, coercions: 0, joins: 0/0} +$dIP :: GHC.Stack.Types.CallStack +[GblId] +$dIP = GHC.Stack.Types.pushCallStack (GHC.CString.unpackCString# "error"#, GHC.Stack.Types.SrcLoc (GHC.CString.unpackCString# "main"#) (GHC.CString.unpackCString# "T24296b"#) (GHC.CString.unpackCString# "T24296b.hs"#) (GHC.Types.I# 5#) (GHC.Types.I# 7#) (GHC.Types.I# 5#) (GHC.Types.I# 12#)) GHC.Stack.Types.emptyCallStack + +-- RHS size: {terms: 5, types: 4, coercions: 4, joins: 0/0} +f :: Int -> Int -> Int +[GblId, Arity=1, Unf=OtherCon []] +f = \ _ [Occ=Dead] -> error @GHC.Types.LiftedRep @(Int -> Int) ($dIP `cast` (Sym (GHC.Classes.N:IP[0] <"callStack">_N <GHC.Stack.Types.CallStack>_N) :: GHC.Stack.Types.CallStack ~R# (?callStack::GHC.Stack.Types.CallStack))) (GHC.CString.unpackCString# "blah"#) + +-- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} +r [InlPrag=OPAQUE] :: Int -> Int -> Maybe Int +[GblId, Arity=2, Unf=OtherCon []] +r = \ (x :: Int) (y :: Int) -> case g f y of { __DEFAULT -> GHC.Maybe.Just @Int (g f x y) } + + + diff --git a/testsuite/tests/arityanal/should_compile/all.T b/testsuite/tests/arityanal/should_compile/all.T index 6124bf12c9d5174c2818fe1e909b779428e5f0c5..52df0f134337de3de09047657f0623ee6720b769 100644 --- a/testsuite/tests/arityanal/should_compile/all.T +++ b/testsuite/tests/arityanal/should_compile/all.T @@ -1,24 +1,26 @@ # "Unit tests" -test('Arity00', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity01', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity02', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity03', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity04', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity05', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity06', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity07', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity08', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity09', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity10', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity11', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity12', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity13', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity14', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity15', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) -test('Arity16', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) +dump_simpl_opts = ' -dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques ' +test('Arity00', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity01', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity02', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity03', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity04', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity05', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity06', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity07', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity08', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity09', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity10', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity11', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity12', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity13', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity14', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity15', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) +test('Arity16', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) # Regression tests -test('T18793', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) +test('T18793', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, [dump_simpl_opts]) test('T18870', [ only_ways(['optasm']) ], compile, ['-ddebug-output']) test('T18937', [ only_ways(['optasm']) ], compile, ['-ddebug-output']) -test('T21755', [ grep_errmsg(r'Arity=') ], compile, ['-O -dno-typeable-binds -fno-worker-wrapper']) +test('T21755', [ grep_errmsg(r'Arity=') ], compile, ['-fno-worker-wrapper' + dump_simpl_opts]) +test('T24296b', [ grep_errmsg(r'g f y') ], compile, ['-fpedantic-bottoms' + dump_simpl_opts]) diff --git a/testsuite/tests/arityanal/should_run/T24296.hs b/testsuite/tests/arityanal/should_run/T24296.hs new file mode 100644 index 0000000000000000000000000000000000000000..984f7c892b9255bb470d2733cea627f5bff56c63 --- /dev/null +++ b/testsuite/tests/arityanal/should_run/T24296.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GHC2021, UnboxedTuples #-} +module Main (main) where + +newtype Tricky = TrickyCon { unTrickyCon :: (# #) -> Tricky } + +main :: IO () +main = do + let + tricky :: Tricky + {-# OPAQUE tricky #-} + tricky = TrickyCon $ \(# #) -> TrickyCon $ \(# #) -> + error "tricky called with at least two args" + + applyToN :: Int -> Tricky -> Tricky + {-# OPAQUE applyToN #-} + applyToN n a | n == 0 = a + | otherwise = applyToN (n - 1) a `unTrickyCon` (# #) + + case applyToN 12345 tricky of + !_ -> putStrLn "unreachable" diff --git a/testsuite/tests/arityanal/should_run/T24296.stderr b/testsuite/tests/arityanal/should_run/T24296.stderr new file mode 100644 index 0000000000000000000000000000000000000000..84ca18adae58065402efee03f61de5ac14e4d55c --- /dev/null +++ b/testsuite/tests/arityanal/should_run/T24296.stderr @@ -0,0 +1,3 @@ +T24296: tricky called with at least two args +CallStack (from HasCallStack): + error, called at T24296.hs:12:7 in main:Main diff --git a/testsuite/tests/arityanal/should_run/all.T b/testsuite/tests/arityanal/should_run/all.T index c808036854f40a41d8f391c1ab01ebb74e207636..a5403430262ffe084a980c7438a5abd8500dc3f0 100644 --- a/testsuite/tests/arityanal/should_run/all.T +++ b/testsuite/tests/arityanal/should_run/all.T @@ -3,4 +3,5 @@ # Regression tests test('T21652', [ only_ways(['optasm']) ], compile_and_run, ['']) test('T21694a', [ only_ways(['optasm']), exit_code(1) ], compile_and_run, ['-fpedantic-bottoms']) +test('T24296', [ only_ways(['optasm']), exit_code(1) ], compile_and_run, ['-fpedantic-bottoms'])