[Git][ghc/ghc][wip/T24296] Arity: Require called *exactly once* for eta exp with -fpedantic-bottoms (#24296)

Sebastian Graf (@sgraf812) gitlab at gitlab.haskell.org
Thu Jan 11 12:23:06 UTC 2024



Sebastian Graf pushed to branch wip/T24296 at Glasgow Haskell Compiler / GHC


Commits:
4536f41f by Sebastian Graf at 2024-01-11T13:22:49+01: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/4536f41fb8ec50f6ba4accf0055c38cbd95a9507

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4536f41fb8ec50f6ba4accf0055c38cbd95a9507
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/77ac50ca/attachment-0001.html>


More information about the ghc-commits mailing list