[Git][ghc/ghc][wip/T23398] 3 commits: Use setSrcSpan rather than setLclEnv in solveForAll

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Thu May 18 07:32:04 UTC 2023



Simon Peyton Jones pushed to branch wip/T23398 at Glasgow Haskell Compiler / GHC


Commits:
5fe1d3e6 by Matthew Pickering at 2023-05-17T21:42:00-04:00
Use setSrcSpan rather than setLclEnv in solveForAll

In subsequent MRs (#23409) we want to remove the TcLclEnv argument from
a CtLoc. This MR prepares us for that by removing the one place where
the entire TcLclEnv is used, by using it more precisely to just set the
contexts source location.

Fixes #23390

- - - - -
385edb65 by Torsten Schmits at 2023-05-17T21:42:40-04:00
Update the users guide paragraph on -O in GHCi

In relation to #23056

- - - - -
41f77ee5 by Simon Peyton Jones at 2023-05-18T08:33:58+01:00
Allow the demand analyser to unpack tuple and equality dictionaries

Addresses #23398. The demand analyser usually does not unpack class
dictionaries: see Note [Do not unbox class dictionaries] in
GHC.Core.Opt.DmdAnal.

This patch makes an exception for tuple dictionaries and equality
dictionaries, for reasons explained in wrinkles (DNB1) and (DNB2) of
the above Note.

Compile times fall by 0.1% for some reason (max 0.7% on T18698b).

- - - - -


9 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Monad.hs
- docs/users_guide/ghci.rst
- testsuite/tests/indexed-types/should_compile/T7837.stderr
- + testsuite/tests/stranal/should_compile/T23398.hs
- + testsuite/tests/stranal/should_compile/T23398.stderr
- testsuite/tests/stranal/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -16,37 +16,41 @@ where
 
 import GHC.Prelude
 
-import GHC.Core.Opt.WorkWrap.Utils
 import GHC.Types.Demand   -- All of it
+
 import GHC.Core
-import GHC.Core.Multiplicity ( scaledThing )
-import GHC.Utils.Outputable
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Basic
-import Data.List        ( mapAccumL )
 import GHC.Core.DataCon
-import GHC.Types.ForeignCall ( isSafeForeignCall )
-import GHC.Types.Id
 import GHC.Core.Utils
 import GHC.Core.TyCon
 import GHC.Core.Type
-import GHC.Core.Predicate( isClassPred )
+import GHC.Core.Predicate( isEqualityClass, isCTupleClass )
 import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
 import GHC.Core.Coercion ( Coercion )
 import GHC.Core.TyCo.FVs     ( coVarsOfCos )
 import GHC.Core.TyCo.Compare ( eqType )
+import GHC.Core.Multiplicity ( scaledThing )
 import GHC.Core.FamInstEnv
 import GHC.Core.Opt.Arity ( typeArity )
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
+import GHC.Core.Opt.WorkWrap.Utils
+
 import GHC.Builtin.PrimOps
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
+
 import GHC.Types.Unique.Set
 import GHC.Types.Unique.MemoFun
 import GHC.Types.RepType
+import GHC.Types.ForeignCall ( isSafeForeignCall )
+import GHC.Types.Id
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set
+import GHC.Types.Basic
 
+import GHC.Utils.Misc
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Outputable
+
+import Data.List        ( mapAccumL )
 
 {-
 ************************************************************************
@@ -1499,7 +1503,7 @@ bounds-checking.
 
 So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S><S!S>b`
 where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments
-are unboxed (recursively).  The wrapper for `indexError` won't /acutally/
+are unboxed (recursively).  The wrapper for `indexError` won't /actually/
 unbox them (because their polymorphic type doesn't allow that) but when
 demand-analysing /callers/, we'll behave as if that call needs the args
 unboxed.
@@ -1782,39 +1786,6 @@ applying the strictness demands to the final result of DmdAnal. The result is
 that we get the strict demand signature we wanted even if we can't float
 the case on `x` up through the case on `burble`.
 
-Note [Do not unbox class dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We never unbox class dictionaries in worker/wrapper.
-
-1. INLINABLE functions
-   If we have
-      f :: Ord a => [a] -> Int -> a
-      {-# INLINABLE f #-}
-   and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
-   (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
-   which can still be specialised by the type-class specialiser, something like
-      fw :: Ord a => [a] -> Int# -> a
-
-   BUT if f is strict in the Ord dictionary, we might unpack it, to get
-      fw :: (a->a->Bool) -> [a] -> Int# -> a
-   and the type-class specialiser can't specialise that. An example is #6056.
-
-   Historical note: #14955 describes how I got this fix wrong the first time.
-   I got aware of the issue in T5075 by the change in boxity of loop between
-   demand analysis runs.
-
-2. -fspecialise-aggressively.  As #21286 shows, the same phenomenon can occur
-   occur without INLINABLE, when we use -fexpose-all-unfoldings and
-   -fspecialise-aggressively to do vigorous cross-module specialisation.
-
-3. #18421 found that unboxing a dictionary can also make the worker less likely
-   to inline; the inlining heuristics seem to prefer to inline a function
-   applied to a dictionary over a function applied to a bunch of functions.
-
-TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing
-a raft of higher-order functions isn't a huge win anyway -- you really want to
-specialise the function.
-
 Note [Worker argument budget]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In 'finaliseArgBoxities' we don't want to generate workers with zillions of
@@ -1998,22 +1969,13 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
 
     arg_triples :: [(Type, StrictnessMark, Demand)]
     arg_triples = take threshold_arity $
-                  [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty)
-                  | bndr <- bndrs
-                  , isRuntimeVar bndr, let bndr_ty = idType bndr ]
-
-    get_dmd :: Id -> Type -> Demand
-    get_dmd bndr bndr_ty
-      | isClassPred bndr_ty = trimBoxity dmd
-        -- See Note [Do not unbox class dictionaries]
-        -- NB: 'ty' has not been normalised, so this will (rightly)
-        --     catch newtype dictionaries too.
-        -- NB: even for bottoming functions, don't unbox dictionaries
-
-      | is_bot_fn = unboxDeeplyDmd dmd
-        -- See Note [Boxity for bottoming functions], case (B)
-
-      | otherwise = dmd
+                  [ (idType bndr, NotMarkedStrict, get_dmd bndr)
+                  | bndr <- bndrs, isRuntimeVar bndr ]
+
+    get_dmd :: Id -> Demand
+    get_dmd bndr
+      | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions],
+      | otherwise = dmd                --     case (B)
       where
         dmd = idDemandInfo bndr
 
@@ -2119,6 +2081,12 @@ wantToUnboxArg env ty str_mark dmd@(n :* _)
          -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal
        -> DontUnbox
 
+       | doNotUnbox ty
+       -> DontUnbox  -- See Note [Do not unbox class dictionaries]
+                     -- NB: 'ty' has not been normalised, so this will (rightly)
+                     --     catch newtype dictionaries too.
+                     -- NB: even for bottoming functions, don't unbox dictionaries
+
        | DefinitelyRecursive <- ae_rec_dc env dc
          -- See Note [Which types are unboxed?]
          -- and Note [Demand analysis for recursive data constructors]
@@ -2129,6 +2097,76 @@ wantToUnboxArg env ty str_mark dmd@(n :* _)
                         (dataConRepStrictness dc)
                         dmds)
 
+
+doNotUnbox :: Type -> Bool
+-- Do not unbox class dictionaries, except equality classes and tuples
+-- Note [Do not unbox class dictionaries]
+doNotUnbox arg_ty
+  = case tyConAppTyCon_maybe arg_ty of
+      Just tc | Just cls <- tyConClass_maybe tc
+              -> not (isEqualityClass cls || isCTupleClass cls)
+       -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]
+
+    _ -> False
+
+{- Note [Do not unbox class dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never unbox class dictionaries in worker/wrapper.
+
+1. INLINABLE functions
+   If we have
+      f :: Ord a => [a] -> Int -> a
+      {-# INLINABLE f #-}
+   and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
+   (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
+   which can still be specialised by the type-class specialiser, something like
+      fw :: Ord a => [a] -> Int# -> a
+
+   BUT if f is strict in the Ord dictionary, we might unpack it, to get
+      fw :: (a->a->Bool) -> [a] -> Int# -> a
+   and the type-class specialiser can't specialise that. An example is #6056.
+
+   Historical note: #14955 describes how I got this fix wrong the first time.
+   I got aware of the issue in T5075 by the change in boxity of loop between
+   demand analysis runs.
+
+2. -fspecialise-aggressively.  As #21286 shows, the same phenomenon can occur
+   occur without INLINABLE, when we use -fexpose-all-unfoldings and
+   -fspecialise-aggressively to do vigorous cross-module specialisation.
+
+3. #18421 found that unboxing a dictionary can also make the worker less likely
+   to inline; the inlining heuristics seem to prefer to inline a function
+   applied to a dictionary over a function applied to a bunch of functions.
+
+TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing
+a raft of higher-order functions isn't a huge win anyway -- you really want to
+specialise the function.
+
+Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398)
+     f :: (% Eq a, Show a %) => blah
+  with -fdicts-strict it is great to unbox to
+     $wf :: Eq a => Show a => blah
+  (where I have written out the currying explicitly).  Now we can specialise
+  $wf on the Eq or Show dictionary.  Nothing is lost.
+
+  And something is gained.  It is possible that `f` will look like this:
+     f = /\a. \d:(% Eq a, Show a %). ... f @a (% sel1 d, sel2 d %)...
+  where there is a recurive call to `f`, or to another function that takes the
+  same tuple dictionary, but where the tuple is built from the components of
+  `d`.  The Simplier does not fix this.  But if we unpacked the dictionary
+  we'd get
+     $wf = /\a. \(d1:Eq a) (d2:Show a). let d = (% d1, d2 %)
+             in ...f @a (% sel1 d, sel2 d %)
+  and all the tuple building and taking apart will disappear.
+
+Wrinkle (DNB2): we /do/ wnat to unbox equality dictionaries,
+  for (~), (~~), and Coercible (#23398).  Their payload is a single unboxed
+  coercion.  We never want to specialise on `(t1 ~ t2)`.  All that would do is
+  to make a copy of the function's RHS with a particular coercion.  Unlike
+  normal class methods, that does not unlock any new optimisation
+  opportunities in the specialised RHS.
+-}
+
 {- *********************************************************************
 *                                                                      *
                       Fixpoints


=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -20,7 +20,7 @@ module GHC.Core.Predicate (
 
   -- Class predicates
   mkClassPred, isDictTy, typeDeterminesValue,
-  isClassPred, isEqPredClass, isCTupleClass,
+  isClassPred, isEqPredClass, isCTupleClass, isEqualityClass,
   getClassPredTys, getClassPredTys_maybe,
   classMethodTy, classMethodInstTy,
 
@@ -219,11 +219,6 @@ isEvVarType :: Type -> Bool
 -- See Note [Evidence for quantified constraints]
 isEvVarType ty = isCoVarType ty || isPredTy ty
 
-isEqPredClass :: Class -> Bool
--- True of (~) and (~~)
-isEqPredClass cls =  cls `hasKey` eqTyConKey
-                  || cls `hasKey` heqTyConKey
-
 isClassPred :: PredType -> Bool
 isClassPred ty = case tyConAppTyCon_maybe ty of
     Just tc -> isClassTyCon tc
@@ -245,6 +240,20 @@ isEqPrimPred ty = isCoVarType ty
 isCTupleClass :: Class -> Bool
 isCTupleClass cls = isTupleTyCon (classTyCon cls)
 
+isEqPredClass :: Class -> Bool
+-- True of (~) and (~~)
+isEqPredClass cls =  cls `hasKey` eqTyConKey
+                  || cls `hasKey` heqTyConKey
+
+isEqualityClass :: Class -> Bool
+-- True of (~), (~~), and Coercible
+-- These all have a single primitive-equality superclass, either (~N# or ~R#)
+isEqualityClass cls
+  = cls `hasKey` heqTyConKey
+    || cls `hasKey` eqTyConKey
+    || cls `hasKey` coercibleTyConKey
+
+
 {- *********************************************************************
 *                                                                      *
               Implicit parameters


=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Data.Bag
 
 import Data.Maybe ( isJust )
 import qualified Data.Semigroup as S
+import GHC.Tc.Utils.Monad (getLclEnvLoc)
 
 {-
 ************************************************************************
@@ -876,8 +877,8 @@ solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> ExpansionFuel
 solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
             tvs theta pred _fuel
   = -- See Note [Solving a Wanted forall-constraint]
-    setLclEnv (ctLocEnv loc) $
-    -- This setLclEnv is important: the emitImplicationTcS uses that
+    setSrcSpan (getLclEnvLoc $ ctLocEnv loc) $
+    -- This setSrcSpan is important: the emitImplicationTcS uses that
     -- TcLclEnv for the implication, and that in turn sets the location
     -- for the Givens when solving the constraint (#21006)
     do { let empty_subst = mkEmptySubst $ mkInScopeSet $


=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -57,7 +57,7 @@ module GHC.Tc.Solver.Monad (
     getSolvedDicts, setSolvedDicts,
 
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
-    getTopEnv, getGblEnv, getLclEnv, setLclEnv,
+    getTopEnv, getGblEnv, getLclEnv, setSrcSpan,
     getTcEvBindsVar, getTcLevel,
     getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
     tcLookupClass, tcLookupId, tcLookupTyCon,
@@ -194,6 +194,7 @@ import Data.IORef
 import Data.List ( mapAccumL )
 import Data.Foldable
 import qualified Data.Semigroup as S
+import GHC.Types.SrcLoc
 
 #if defined(DEBUG)
 import GHC.Types.Unique.Set (nonDetEltsUniqSet)
@@ -1398,8 +1399,8 @@ getGblEnv = wrapTcS $ TcM.getGblEnv
 getLclEnv :: TcS TcLclEnv
 getLclEnv = wrapTcS $ TcM.getLclEnv
 
-setLclEnv :: TcLclEnv -> TcS a -> TcS a
-setLclEnv env = wrap2TcS (TcM.setLclEnv env)
+setSrcSpan :: RealSrcSpan -> TcS a -> TcS a
+setSrcSpan ss = wrap2TcS (TcM.setSrcSpan (RealSrcSpan ss mempty))
 
 tcLookupClass :: Name -> TcS Class
 tcLookupClass c = wrapTcS $ TcM.tcLookupClass c


=====================================
docs/users_guide/ghci.rst
=====================================
@@ -3546,41 +3546,19 @@ The interpreter can't load modules with foreign export declarations!
     Unfortunately not. We haven't implemented it yet. Please compile any
     offending modules by hand before loading them into GHCi.
 
-:ghc-flag:`-O` doesn't work with GHCi!
+:ghc-flag:`-O` is ineffective in GHCi!
 
     .. index::
        single: optimization; and GHCi
 
-    For technical reasons, the bytecode compiler doesn't interact well
-    with one of the optimisation passes, so we have disabled
-    optimisation when using the interpreter. This isn't a great loss:
-    you'll get a much bigger win by compiling the bits of your code that
-    need to go fast, rather than interpreting them with optimisation
-    turned on.
+    Before GHC 9.8, optimizations were considered too unstable to be used with
+    the bytecode interpreter.
+    This restriction has been lifted, but is still regarded as experimental and
+    guarded by :ghc-flag:`-funoptimized-core-for-interpreter`, which is enabled
+    by default.
+    In order to use optimizations, run: ::
 
-Modules using unboxed tuples or sums will automatically enable :ghc-flag:`-fobject-code`
-
-    .. index::
-       single: unboxed tuples, sums; and GHCi
-
-    The bytecode interpreter doesn't support most uses of unboxed tuples or
-    sums, so GHCi will automatically compile these modules, and all modules
-    they depend on, to object code instead of bytecode.
-
-    GHCi checks for the presence of unboxed tuples and sums in a somewhat
-    conservative fashion: it simply checks to see if a module enables the
-    :extension:`UnboxedTuples` or :extension:`UnboxedSums` language extensions.
-    It is not always the case that code which enables :extension:`UnboxedTuples`
-    or :extension:`UnboxedSums` requires :ghc-flag:`-fobject-code`, so if you
-    *really* want to compile
-    :extension:`UnboxedTuples`/:extension:`UnboxedSums`-using code to
-    bytecode, you can do so explicitly by enabling the :ghc-flag:`-fbyte-code`
-    flag. If you do this, do note that bytecode interpreter will throw an error
-    if it encounters unboxed tuple/sum–related code that it cannot handle.
-
-    Incidentally, the previous point, that :ghc-flag:`-O` is
-    incompatible with GHCi, is because the bytecode compiler can't
-    deal with unboxed tuples or sums.
+      ghci -fno-unoptimized-core-for-interpreter -O
 
 Concurrent threads don't carry on running when GHCi is waiting for input.
     This should work, as long as your GHCi was built with the


=====================================
testsuite/tests/indexed-types/should_compile/T7837.stderr
=====================================
@@ -1,3 +1,4 @@
 Rule fired: Class op signum (BUILTIN)
 Rule fired: Class op abs (BUILTIN)
 Rule fired: normalize/Double (T7837)
+Rule fired: Class op eq_sel (BUILTIN)


=====================================
testsuite/tests/stranal/should_compile/T23398.hs
=====================================
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fdicts-strict #-}
+module T23398 where
+
+type PairDict a = (Eq a, Show a)
+
+foo :: PairDict a => a -> a -> String
+foo x y | x==y      = show x
+        | otherwise = show y
+
+-- In worker/wrapper we'd like to unbox the pair
+-- but not (Eq a) and (Show a)
+
+bar :: (a ~ b, Show a) => Int -> a -> (b, String)
+bar 0 x = (x, show x)
+bar n x = bar (n-1) x


=====================================
testsuite/tests/stranal/should_compile/T23398.stderr
=====================================
@@ -0,0 +1,109 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 76, types: 117, coercions: 4, joins: 0/0}
+
+-- RHS size: {terms: 18, types: 11, coercions: 0, joins: 0/0}
+T23398.$wfoo [InlPrag=[2]]
+  :: forall {a}. (Eq a, Show a) => a -> a -> String
+[GblId[StrictWorker([!, !])],
+ Arity=4,
+ Str=<SP(1C(1,C(1,L)),A)><SP(A,1C(1,L),A)><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=IF_ARGS [30 60 0 0] 120 0}]
+T23398.$wfoo
+  = \ (@a) (ww :: Eq a) (ww1 :: Show a) (eta :: a) (eta1 :: a) ->
+      case == @a ww eta eta1 of {
+        False -> show @a ww1 eta1;
+        True -> show @a ww1 eta
+      }
+
+-- RHS size: {terms: 12, types: 12, coercions: 0, joins: 0/0}
+foo [InlPrag=[2]] :: forall a. PairDict a => a -> a -> String
+[GblId,
+ Arity=3,
+ Str=<S!P(SP(SC(S,C(1,L)),A),SP(A,SC(S,L),A))><L><L>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@a)
+                 ($d(%,%) [Occ=Once1!] :: PairDict a)
+                 (eta [Occ=Once1] :: a)
+                 (eta1 [Occ=Once1] :: a) ->
+                 case $d(%,%) of { (ww [Occ=Once1], ww1 [Occ=Once1]) ->
+                 T23398.$wfoo @a ww ww1 eta eta1
+                 }}]
+foo
+  = \ (@a) ($d(%,%) :: PairDict a) (eta :: a) (eta1 :: a) ->
+      case $d(%,%) of { (ww, ww1) -> T23398.$wfoo @a ww ww1 eta eta1 }
+
+Rec {
+-- RHS size: {terms: 21, types: 19, coercions: 3, joins: 0/0}
+T23398.$wbar [InlPrag=[2], Occ=LoopBreaker]
+  :: forall {a} {b}.
+     (a GHC.Prim.~# b, Show a) =>
+     GHC.Prim.Int# -> a -> (# b, String #)
+[GblId[StrictWorker([~, !])],
+ Arity=4,
+ Str=<L><SP(A,SC(S,L),A)><1L><L>,
+ Unf=OtherCon []]
+T23398.$wbar
+  = \ (@a)
+      (@b)
+      (ww :: a GHC.Prim.~# b)
+      ($dShow :: Show a)
+      (ww1 :: GHC.Prim.Int#)
+      (eta :: a) ->
+      case ww1 of ds {
+        __DEFAULT ->
+          T23398.$wbar
+            @a @b @~(ww :: a GHC.Prim.~# b) $dShow (GHC.Prim.-# ds 1#) eta;
+        0# -> (# eta `cast` (Sub ww :: a ~R# b), show @a $dShow eta #)
+      }
+end Rec }
+
+-- RHS size: {terms: 21, types: 32, coercions: 1, joins: 0/0}
+bar [InlPrag=[2]]
+  :: forall a b. (a ~ b, Show a) => Int -> a -> (b, String)
+[GblId,
+ Arity=4,
+ Str=<S!P(L)><SP(A,SC(S,L),A)><1!P(1L)><L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+         Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@a)
+                 (@b)
+                 ($d~ [Occ=Once1!] :: a ~ b)
+                 ($dShow [Occ=Once1] :: Show a)
+                 (eta [Occ=Once1!] :: Int)
+                 (eta1 [Occ=Once1] :: a) ->
+                 case $d~ of { GHC.Types.Eq# ww ->
+                 case eta of { GHC.Types.I# ww1 [Occ=Once1] ->
+                 case T23398.$wbar @a @b @~(ww :: a GHC.Prim.~# b) $dShow ww1 eta1
+                 of
+                 { (# ww2 [Occ=Once1], ww3 [Occ=Once1] #) ->
+                 (ww2, ww3)
+                 }
+                 }
+                 }}]
+bar
+  = \ (@a)
+      (@b)
+      ($d~ :: a ~ b)
+      ($dShow :: Show a)
+      (eta :: Int)
+      (eta1 :: a) ->
+      case $d~ of { GHC.Types.Eq# ww ->
+      case eta of { GHC.Types.I# ww1 ->
+      case T23398.$wbar @a @b @~(ww :: a GHC.Prim.~# b) $dShow ww1 eta1
+      of
+      { (# ww2, ww3 #) ->
+      (ww2, ww3)
+      }
+      }
+      }
+
+
+


=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -93,3 +93,4 @@ test('T22039', normal, compile, [''])
 test('T22388', [ grep_errmsg(r'^\S+\$w\S+') ], compile, ['-dsuppress-uniques -ddump-simpl'])
 # T22997: Just a panic that should not happen
 test('T22997', normal, compile, [''])
+test('T23398', normal, compile, ['-dsuppress-uniques -ddump-simpl -dno-typeable-binds'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe0e8c9c13916d4e32b65543c083d227db256d23...41f77ee59cd74819f0e6c11d41b3020e12474a4a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fe0e8c9c13916d4e32b65543c083d227db256d23...41f77ee59cd74819f0e6c11d41b3020e12474a4a
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/20230518/4fd2df15/attachment-0001.html>


More information about the ghc-commits mailing list