[Git][ghc/ghc][wip/marge_bot_batch_merge_job] Arity: Require called *exactly once* for eta exp with -fpedantic-bottoms (#24296)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Jan 11 18:58:28 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8ec92ae6 by Sebastian Graf at 2024-01-11T13:58:02-05:00
Arity: Require called *exactly once* for eta exp with -fpedantic-bottoms (#24296)
In #24296, we had a program in which we eta expanded away an error despite the
presence of `-fpedantic-bottoms`.
This was caused by turning called *at least once* lambdas into one-shot lambdas,
while with `-fpedantic-bottoms` it is only sound to eta expand over lambdas that
are called *exactly* once.
An example can be found in `Note [Combining arity type with demand info]`.
Fixes #24296.
- - - - -
15 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Stg/Lift/Analysis.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/arityanal/should_compile/T21755.stderr
- + testsuite/tests/arityanal/should_compile/T24296b.hs
- + testsuite/tests/arityanal/should_compile/T24296b.stderr
- testsuite/tests/arityanal/should_compile/all.T
- + testsuite/tests/arityanal/should_run/T24296.hs
- + testsuite/tests/arityanal/should_run/T24296.stderr
- testsuite/tests/arityanal/should_run/all.T
Changes:
=====================================
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
=====================================
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
=====================================
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.
-}
=====================================
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
=====================================
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
=====================================
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
=====================================
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 at inalities and @Demand at 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]
~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
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
=====================================
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#)
+ }
+
+
+
=====================================
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 #-}
=====================================
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) }
+
+
+
=====================================
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])
=====================================
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"
=====================================
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
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8ec92ae6e20806f922224955399255bcd4bcd0b7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8ec92ae6e20806f922224955399255bcd4bcd0b7
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/20240111/4614bb28/attachment-0001.html>
More information about the ghc-commits
mailing list