GitLab

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

fc555f08

by Simon Hengel at 2025-11-27T07:42:43-05:00

Fix typo in docs/users_guide/exts/type_families.rst

8d213a1c
by Simon Hengel at 2025-11-27T07:42:44-05:00
```
Fix broken RankNTypes example in user's guide
```

2bae26ae

by Simon Peyton Jones at 2025-11-27T07:42:44-05:00

Switch off specialisation in ExactPrint

In !15057 (where we re-introduced -fpolymoprhic-specialisation) we found
that ExactPrint's compile time blew up by a factor of 5.  It turned out
to be caused by bazillions of specialisations of `markAnnotated`.

Since ExactPrint isn't perf-critical, it does not seem worth taking
the performance hit, so this patch switches off specialisation in
this one module.

eddea2d2

by Simon Peyton Jones at 2025-11-27T07:42:44-05:00

Switch -fpolymorphic-specialisation on by default

This patch addresses #23559.

Now that !10479 has landed and #26329 is fixed, we can switch on
polymorphic specialisation by default, addressing a bunch of other
tickets listed in #23559.

Metric changes:
  * CoOpt_Singleton: +4% compiler allocations: we just get more
    specialisations

  * info_table_map_perf: -20% decrease in compiler allocations.
    This is caused by using -fno-specialise in ExactPrint.hs
    Without that change we get a 4x blow-up in compile time;
    see !15058 for details

Metric Decrease:
    info_table_map_perf
Metric Increase:
    CoOpt_Singletons

f274cc23

by Matthew Pickering at 2025-11-27T07:42:45-05:00

rts: Fix a deadlock with eventlog flush interval and RTS shutdown

The ghc_ticker thread attempts to flush at the eventlog tick interval, this requires
waiting to take all capabilities.

At the same time, the main thread is shutting down, the schedule is
stopped and then we wait for the ticker thread to finish.

Therefore we are deadlocked.

The solution is to use `newBoundTask/exitMyTask`, so that flushing can
cooperate with the scheduler shutdown.

Fixes #26573

8b566aa6

by sheaf at 2025-11-27T07:42:58-05:00

SimpleOpt: don't subst in pushCoercionIntoLambda

It was noticed in #26589 that the change in 15b311be was incorrect:
the simple optimiser carries two different substitution-like pieces of
information: 'soe_subst' (from InVar to OutExpr) and 'soe_inl'
(from InId to InExpr). It is thus incorrect to have 'pushCoercionIntoLambda'
apply the substitution from 'soe_subst' while discarding 'soe_inl'
entirely, which is what was done in 15b311be.

Instead, we change back pushCoercionIntoLambda to take an InScopeSet,
and optimise the lambda before calling 'pushCoercionIntoLambda' to avoid
mixing InExpr with OutExpr, or mixing two InExpr with different
environments. We can then call 'soeZapSubst' without problems.

Fixes #26588 #26589

15 changed files:

compiler/GHC/Core/Opt/Arity.hs
compiler/GHC/Core/SimpleOpt.hs
compiler/GHC/Driver/DynFlags.hs
compiler/GHC/Driver/Flags.hs
compiler/GHC/Tc/Gen/App.hs
docs/users_guide/exts/rank_polymorphism.rst
docs/users_guide/exts/type_families.rst
docs/users_guide/using-optimisation.rst
rts/eventlog/EventLog.c
testsuite/tests/rts/all.T
+ testsuite/tests/simplCore/should_compile/T26588.hs
+ testsuite/tests/simplCore/should_compile/T26589.hs
testsuite/tests/simplCore/should_compile/T8331.stderr
testsuite/tests/simplCore/should_compile/all.T
utils/check-exact/ExactPrint.hs

Changes:

compiler/GHC/Core/Opt/Arity.hs

@@ -2993,12 +2993,12 @@ pushCoValArg co
      Pair tyL tyR = coercionKind co
  pushCoercionIntoLambda
 -    :: HasDebugCallStack => Subst -> InVar -> InExpr -> OutCoercionR -> Maybe (OutVar, OutExpr)
 +    :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)
  -- This implements the Push rule from the paper on coercions
  --    (\x. e) |> co
  -- ===>
  --    (\x'. e |> co')
 -pushCoercionIntoLambda subst x e co
 +pushCoercionIntoLambda in_scope x e co
      | assert (not (isTyVar x) && not (isCoVar x)) True
      , Pair s1s2 t1t2 <- coercionKind co
      , Just {}              <- splitFunTy_maybe s1s2
@@ -3011,9 +3011,9 @@ pushCoercionIntoLambda subst x e co
            -- Should we optimize the coercions here?
            -- Otherwise they might not match too well
            x' = x `setIdType` t1 `setIdMult` w1
 -          in_scope' = substInScopeSet subst `extendInScopeSet` x'
 +          in_scope' = in_scope `extendInScopeSet` x'
            subst' =
 -            extendIdSubst (setInScope subst in_scope')
 +            extendIdSubst (setInScope emptySubst in_scope')
+               x
                (mkCast (Var x') (mkSymCo co1))
              -- We substitute x' for x, except we need to preserve types.

compiler/GHC/Core/SimpleOpt.hs

@@ -393,12 +393,19 @@ simple_app env e0@(Lam {}) as0@(_:_)
        = wrapLet mb_pr $ do_beta env'' body as
        where (env', b') = subst_opt_bndr env b
 -    do_beta env e@(Lam b body) as@(CastIt co:rest)
 -      -- See Note [Desugaring unlifted newtypes]
 +    -- See Note [Eliminate casts in function position]
 +    do_beta env e@(Lam b _) as@(CastIt out_co:rest)
        | isNonCoVarId b
 -      , Just (b', body') <- pushCoercionIntoLambda (soe_subst env) b body co
 +      -- Optimise the inner lambda to make it an 'OutExpr', which makes it
 +      -- possible to call 'pushCoercionIntoLambda' with the 'OutCoercion' 'co'.
 +      -- This is kind of horrible, as for nested casted lambdas with a big body,
 +      -- we will repeatedly optimise the body (once for each binder). However,
 +      -- we need to do this to avoid mixing 'InExpr' and 'OutExpr', or two
 +      -- 'InExpr' with different environments (getting this wrong caused #26588 & #26589.)
 +      , Lam out_b out_body <- simple_app env e []
 +      , Just (b', body') <- pushCoercionIntoLambda (soeInScope env) out_b out_body out_co
        = do_beta (soeZapSubst env) (Lam b' body') rest
 -        -- soeZapSubst: pushCoercionIntoLambda applies the substitution
 +        -- soeZapSubst: we've already optimised everything (the lambda and 'rest') by now.
        | otherwise
        = rebuild_app env (simple_opt_expr env e) as
@@ -511,7 +518,31 @@ TL;DR: To avoid the rest of the compiler pipeline seeing these bad lambas, we
  rely on the simple optimiser to both inline the newtype unfolding and
  subsequently deal with the resulting lambdas (either beta-reducing them
  altogether or pushing coercions into them so that they satisfy the
 -representation-polymorphism invariants).
 +representation-polymorphism invariants). See Note [Eliminate casts in function position].
++
 +[Alternative approach] (GHC ticket #26608)
++
 +  We could instead, in the typechecker, emit a special form (a new constructor
 +  of XXExprGhcTc) for instantiations of representation-polymorphic unlifted
 +  newtypes (whether applied to a value argument or not):
++
 +    UnliftedNT :: DataCon -> [Type] -> Coercion -> XXExprGhcTc
++
 +  where "UnliftedNT nt_con [ty1, ...] co" represents the expression:
++
 +    ( nt_con @ty1 ... ) |> co
++
 +  The desugarer would then turn these AST nodes into appropriate Core, doing
 +  what the simple optimiser does today:
 +    - inline the compulsory unfolding of the newtype constructor
 +    - apply it to its type arguments and beta reduce
 +    - push the coercion into the resulting lambda
++
 +  This would have several advantages:
 +    - the desugarer would never produce "invalid" Core that needs to be
 +      tidied up by the simple optimiser,
 +    - the ugly and inefficient implementation described in
 +      Note [Eliminate casts in function position] could be removed.
  Wrinkle [Unlifted newtypes with wrappers]
@@ -717,50 +748,49 @@ rhss here.
  Note [Eliminate casts in function position]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -Consider the following program:
 +Due to the current implementation strategy for representation-polymorphic
 +unlifted newtypes, as described in Note [Desugaring unlifted newtypes], we rely
 +on the simple optimiser to push coercions into lambdas, such as in the following
 +example:
    type R :: Type -> RuntimeRep
 -  type family R a where { R Float = FloatRep; R Double = DoubleRep }
 -  type F :: forall (a :: Type) -> TYPE (R a)
 -  type family F a where { F Float = Float#  ; F Double = Double# }
 +  type family R a where { R Int = IntRep }
 +  type F :: forall a -> TYPE (R a)
 +  type family F a where { F Int = Int# }
 -  type N :: forall (a :: Type) -> TYPE (R a)
    newtype N a = MkN (F a)
 -As MkN is a newtype, its unfolding is a lambda which wraps its argument
 -in a cast:
+-
 -  MkN :: forall (a :: Type). F a -> N a
 -  MkN = /\a \(x::F a). x |> co_ax
 -    -- recall that F a :: TYPE (R a)
+-
 -This is a representation-polymorphic lambda, in which the binder has an unknown
 -representation (R a). We can't compile such a lambda on its own, but we can
 -compile instantiations, such as `MkN @Float` or `MkN @Double`.
 +Now, an instantiated occurrence of 'MkN', such as 'MkN @Int' (whether applied
 +to a value argument or not) will lead, after inlining the compulsory unfolding
 +of 'MkN', to a lambda fo the form:
 -Our strategy to avoid running afoul of the representation-polymorphism
 -invariants of Note [Representation polymorphism invariants] in GHC.Core is thus:
 +  ( \ ( x :: F Int ) -> body ) |> co
 -  1. Give the newtype a compulsory unfolding (it has no binding, as we can't
 -     define lambdas with representation-polymorphic value binders in source Haskell).
 -  2. Rely on the optimiser to beta-reduce away any representation-polymorphic
 -     value binders.
 +    where
 +      co :: ( F Int -> res ) ~# ( Int# -> res )
 -For example, consider the application
 +The problem is that we now have a lambda abstraction whose binder does not have a
 +fixed RuntimeRep in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
 -    MkN @Float 34.0#
 +However, if we use 'pushCoercionIntoLambda', we end up with:
 -After inlining MkN we'll get
 +  ( \ ( x' :: Int# ) -> body' )
 -   ((/\a \(x:F a). x |> co_ax) @Float) |> co 34#
 +which satisfies the representation-polymorphism invariants of
 +Note [Representation polymorphism invariants] in GHC.Core.
 -where co :: (F Float -> N Float) ~ (Float# ~ N Float)
 +In conclusion:
 -But to actually beta-reduce that lambda, we need to push the 'co'
 -inside the `\x` with pushCoercionIntoLambda.  Hence the extra
 -equation for Cast-of-Lam in simple_app.
 +  1. The simple optimiser must push casts into lambdas.
 +  2. It must also deal with a situation such as (MkN @Int) |> co, where we first
 +     inline the compulsory unfolding of N. This means the simple optimiser must
 +     "peel off" the casts and optimise the inner expression first, to determine
 +     whether it is a lambda abstraction or not.
 -This is regrettably delicate.
 +This is regrettably delicate. If we could make sure the typechecker/desugarer
 +did not produce these bad lambdas in the first place (as described in
 +[Alternative approach] in Note [Desugaring unlifted newtypes]), we could
 +get rid of this ugly logic.
  Note [Preserve join-binding arity]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1673,7 +1703,7 @@ exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co)
      -- this implies that x is not in scope in gamma (makes this code simpler)
      , not (isTyVar x) && not (isCoVar x)
      , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True
 -    , Just (x',e') <- pushCoercionIntoLambda (mkEmptySubst in_scope_set) x e co
 +    , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
      , let res = Just (x',e',ts)
      = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
        res

compiler/GHC/Driver/DynFlags.hs

@@ -1268,6 +1268,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
      , ([1,2],   Opt_CfgBlocklayout)      -- Experimental
      , ([1,2],   Opt_Specialise)
 +    , ([1,2],   Opt_PolymorphicSpecialisation)  -- Now on by default (#23559)
      , ([1,2],   Opt_CrossModuleSpecialise)
      , ([1,2],   Opt_InlineGenerics)
      , ([1,2],   Opt_Strictness)

compiler/GHC/Driver/Flags.hs

@@ -909,6 +909,7 @@ optimisationFlags = EnumSet.fromList
     , Opt_SpecialiseAggressively
     , Opt_CrossModuleSpecialise
     , Opt_StaticArgumentTransformation
 +   , Opt_PolymorphicSpecialisation
     , Opt_CSE
     , Opt_StgCSE
     , Opt_StgLiftLams

compiler/GHC/Tc/Gen/App.hs

@@ -749,13 +749,13 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
      go1 _pos acc fun_ty []
         | XExpr (ConLikeTc (RealDataCon dc)) <- tc_fun
         , isNewDataCon dc
 -       , [Scaled _ arg_ty] <- dataConOrigArgTys dc
 +       , [Scaled _ orig_arg_ty] <- dataConOrigArgTys dc
         , n_val_args == 0
         -- If we're dealing with an unsaturated representation-polymorphic
         -- UnliftedNewype, then perform a representation-polymorphism check.
         -- See Note [Representation-polymorphism checks for unsaturated unlifted newtypes]
         -- in GHC.Tc.Utils.Concrete.
 -       , not $ typeHasFixedRuntimeRep arg_ty
 +       , not $ typeHasFixedRuntimeRep orig_arg_ty
         = do { (wrap_co, arg_ty, res_ty) <-
                    matchActualFunTy (FRRRepPolyUnliftedNewtype dc)
                      (Just $ HsExprTcThing tc_fun)

docs/users_guide/exts/rank_polymorphism.rst

@@ -195,7 +195,7 @@ For example: ::
    g3c :: Int -> forall x y. y -> x -> x
    f4 :: (Int -> forall a. (Eq a, Show a) => a -> a) -> Bool
 -  g4 ::  Int -> forall x. (Show x, Eq x) => x -> x) -> Bool
 +  g4 ::  Int -> forall x. (Show x, Eq x) => x -> x
  Then the application ``f3 g3a`` is well-typed, because ``g3a`` has a type that matches the type
  expected by ``f3``.  But ``f3 g3b`` is not well typed, because the foralls are in different places.

docs/users_guide/exts/type_families.rst

@@ -680,7 +680,7 @@ thus: ::
  When doing so, we (optionally) may drop the "``family``" keyword.
  The type parameters must all be type variables, of course, and some (but
 -not necessarily all) of then can be the class parameters. Each class
 +not necessarily all) of them can be the class parameters. Each class
  parameter may only be used at most once per associated type, but some
  may be omitted and they may be in an order other than in the class head.
  Hence, the following contrived example is admissible: ::

docs/users_guide/using-optimisation.rst

@@ -1325,10 +1325,7 @@ as such you shouldn't need to set any of them explicitly. A flag
      :reverse: -fno-polymorphic-specialisation
      :category:
 -    :default: off
+-
 -    Warning, this feature is highly experimental and may lead to incorrect runtime
 -    results. Use at your own risk (:ghc-ticket:`23469`, :ghc-ticket:`23109`, :ghc-ticket:`21229`, :ghc-ticket:`23445`).
 +    :default: on
      Enable specialisation of function calls to known dictionaries with free type variables.
      The created specialisation will abstract over the type variables free in the dictionary.

rts/eventlog/EventLog.c

@@ -491,13 +491,7 @@ endEventLogging(void)
      eventlog_enabled = false;
 -    // Flush all events remaining in the buffers.
 -    //
 -    // N.B. Don't flush if shutting down: this was done in
 -    // finishCapEventLogging and the capabilities have already been freed.
 -    if (getSchedState() != SCHED_SHUTTING_DOWN) {
 -        flushEventLog(NULL);
 -    }
 +    flushEventLog(NULL);
      ACQUIRE_LOCK(&eventBufMutex);
@@ -1626,15 +1620,24 @@ void flushEventLog(Capability **cap USED_IF_THREADS)
          return;
+     }
 +    // N.B. Don't flush if shutting down: this was done in
 +    // finishCapEventLogging and the capabilities have already been freed.
 +    // This can also race against the shutdown if the flush is triggered by the
 +    // ticker thread. (#26573)
 +    if (getSchedState() == SCHED_SHUTTING_DOWN) {
 +      return;
 +    }
++
      ACQUIRE_LOCK(&eventBufMutex);
      printAndClearEventBuf(&eventBuf);
      RELEASE_LOCK(&eventBufMutex);
  #if defined(THREADED_RTS)
 -    Task *task = getMyTask();
 +    Task *task = newBoundTask();
      stopAllCapabilitiesWith(cap, task, SYNC_FLUSH_EVENT_LOG);
      flushAllCapsEventsBufs();
      releaseAllCapabilities(getNumCapabilities(), cap ? *cap : NULL, task);
 +    exitMyTask();
  #else
      flushLocalEventsBuf(getCapability(0));
  #endif

testsuite/tests/rts/all.T

@@ -2,6 +2,11 @@ test('testblockalloc',
       [c_src, only_ways(['normal','threaded1']), extra_run_opts('+RTS -I0')],
       compile_and_run, [''])
 +test('numeric_version_eventlog_flush',
 +     [ignore_stdout, req_ghc_with_threaded_rts],
 +     run_command,
 +     ['{compiler} --numeric-version +RTS -l --eventlog-flush-interval=1 -RTS'])
++
  test('testmblockalloc',
       [c_src, only_ways(['normal','threaded1']), extra_run_opts('+RTS -I0 -xr0.125T'),
        when(arch('wasm32'), skip)], # MBlocks can't be freed on wasm32, see Note [Megablock allocator on wasm] in rts

testsuite/tests/simplCore/should_compile/T26588.hs

 +module T26588 ( getOptionSettingFromText ) where
++
 +import           Control.Applicative ( Const(..) )
 +import           Data.Map (Map)
 +import qualified Data.Map.Strict as Map
++
 +------------------------------------------------------------------------
 +-- ConfigState
++
 +data ConfigLeaf
 +data ConfigTrie = ConfigTrie !(Maybe ConfigLeaf) !ConfigMap
++
 +type ConfigMap = Map Int ConfigTrie
++
 +freshLeaf :: [Int] -> ConfigLeaf -> ConfigTrie
 +freshLeaf [] l     = ConfigTrie (Just l) mempty
 +freshLeaf (a:as) l = ConfigTrie Nothing (Map.singleton a (freshLeaf as l))
++
 +adjustConfigTrie :: Functor t => [Int] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> Maybe (ConfigTrie) -> t (Maybe ConfigTrie)
 +adjustConfigTrie     as f Nothing                 = fmap (freshLeaf as) <$> f Nothing
 +adjustConfigTrie (a:as) f (Just (ConfigTrie x m)) = Just . ConfigTrie x <$> adjustConfigMap a as f m
 +adjustConfigTrie     [] f (Just (ConfigTrie x m)) = g <$> f x
 +  where g Nothing | Map.null m = Nothing
 +        g x' = Just (ConfigTrie x' m)
++
 +adjustConfigMap :: Functor t => Int -> [Int] -> (Maybe ConfigLeaf -> t (Maybe ConfigLeaf)) -> ConfigMap -> t ConfigMap
 +adjustConfigMap a as f = Map.alterF (adjustConfigTrie as f) a
++
 +getOptionSettingFromText :: Int -> [Int] -> ConfigMap -> IO ()
 +getOptionSettingFromText p ps = getConst . adjustConfigMap p ps f
 +  where
 +    f _ = Const (return ())

testsuite/tests/simplCore/should_compile/T26589.hs

 +module T26589 ( executeTest ) where
++
 +-- base
 +import Data.Coerce ( coerce )
 +import Data.Foldable ( foldMap )
++
 +--------------------------------------------------------------------------------
++
 +newtype Traversal f = Traversal { getTraversal :: f () }
++
 +instance Applicative f => Semigroup (Traversal f) where
 +  Traversal f1 <> Traversal f2 = Traversal $ f1 *> f2
 +instance Applicative f => Monoid (Traversal f) where
 +  mempty = Traversal $ pure ()
++
 +newtype Seq a = Seq (FingerTree (Elem a))
 +newtype Elem a = Elem { getElem :: a }
++
 +data FingerTree a
 +    = EmptyT
 +    | Deep !a (FingerTree a) !a
++
 +executeTest :: Seq () -> IO ()
 +executeTest fins = destroyResources
 +  where
 +    destroyResources :: IO ()
 +    destroyResources =
 +      getTraversal $
 +        flip foldMap1 fins $ \ _ ->
 +          Traversal $ return ()
++
 +foldMap1 :: forall m a. Monoid m => (a -> m) -> Seq a -> m
 +foldMap1 = coerce (foldMap2 :: (Elem a -> m) -> FingerTree (Elem a) -> m)
++
 +foldMap2 :: Monoid m => (Elem a -> m) -> FingerTree (Elem a) -> m
 +foldMap2 _ EmptyT = mempty
 +foldMap2 f' (Deep pr' m' sf') = f' pr' <> foldMapTree f' m' <> f' sf'
 +      where
 +        foldMapTree :: Monoid m => (a -> m) -> FingerTree a -> m
 +        foldMapTree _ EmptyT = mempty
 +        foldMapTree f (Deep pr m sf) =
 +            f pr <>
 +            foldMapTree f m <>
 +            f sf

testsuite/tests/simplCore/should_compile/T8331.stderr

  ==================== Tidy Core rules ====================
 +"SPEC $c*> @(ST s) @_"
 +    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
 +      $fApplicativeReaderT_$c*> @(ST s) @r $dApplicative
 +      = ($fApplicativeReaderT2 @s @r)
 +        `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N).
 +                <ReaderT r (ST s) a>_R
 +                ->_R <ReaderT r (ST s) b>_R
 +                ->_R <r>_R ->_R Sym (N:ST <s>_N <b>_R)
 +                     ; Sym (N:ReaderT <*>_N <r>_R <ST s>_R <b>_N)
 +                :: Coercible
 +                     (forall a b.
 +                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s b)
 +                     (forall a b.
 +                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b))
 +"SPEC $c<$ @(ST s) @_"
 +    forall (@s) (@r) ($dFunctor :: Functor (ST s)).
 +      $fFunctorReaderT_$c<$ @(ST s) @r $dFunctor
 +      = ($fApplicativeReaderT6 @s @r)
 +        `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N).
 +                <a>_R
 +                ->_R <ReaderT r (ST s) b>_R
 +                ->_R <r>_R ->_R Sym (N:ST <s>_N <a>_R)
 +                     ; Sym (N:ReaderT <*>_N <r>_R <ST s>_R <a>_N)
 +                :: Coercible
 +                     (forall a b. a -> ReaderT r (ST s) b -> r -> STRep s a)
 +                     (forall a b. a -> ReaderT r (ST s) b -> ReaderT r (ST s) a))
 +"SPEC $c<* @(ST s) @_"
 +    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
 +      $fApplicativeReaderT_$c<* @(ST s) @r $dApplicative
 +      = ($fApplicativeReaderT1 @s @r)
 +        `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N).
 +                <ReaderT r (ST s) a>_R
 +                ->_R <ReaderT r (ST s) b>_R
 +                ->_R <r>_R ->_R Sym (N:ST <s>_N <a>_R)
 +                     ; Sym (N:ReaderT <*>_N <r>_R <ST s>_R <a>_N)
 +                :: Coercible
 +                     (forall a b.
 +                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s a)
 +                     (forall a b.
 +                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) a))
 +"SPEC $c<*> @(ST s) @_"
 +    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
 +      $fApplicativeReaderT9 @(ST s) @r $dApplicative
 +      = ($fApplicativeReaderT4 @s @r)
 +        `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N).
 +                <ReaderT r (ST s) (a -> b)>_R
 +                ->_R <ReaderT r (ST s) a>_R
 +                ->_R <r>_R
 +                ->_R Sym (N:ST <s>_N <b>_R)
 +                :: Coercible
 +                     (forall a b.
 +                      ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b)
 +                     (forall a b.
 +                      ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> ST s b))
 +"SPEC $c>> @(ST s) @_"
 +    forall (@s) (@r) ($dMonad :: Monad (ST s)).
 +      $fMonadReaderT1 @(ST s) @r $dMonad
 +      = $fMonadAbstractIOSTReaderT_$s$c>> @s @r
 +"SPEC $c>>= @(ST s) @_"
 +    forall (@s) (@r) ($dMonad :: Monad (ST s)).
 +      $fMonadReaderT2 @(ST s) @r $dMonad
 +      = ($fMonadAbstractIOSTReaderT2 @s @r)
 +        `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N).
 +                <ReaderT r (ST s) a>_R
 +                ->_R <a -> ReaderT r (ST s) b>_R
 +                ->_R <r>_R
 +                ->_R Sym (N:ST <s>_N <b>_R)
 +                :: Coercible
 +                     (forall a b.
 +                      ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> STRep s b)
 +                     (forall a b.
 +                      ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> ST s b))
 +"SPEC $cfmap @(ST s) @_"
 +    forall (@s) (@r) ($dFunctor :: Functor (ST s)).
 +      $fFunctorReaderT_$cfmap @(ST s) @r $dFunctor
 +      = ($fApplicativeReaderT7 @s @r)
 +        `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N).
 +                <a -> b>_R
 +                ->_R <ReaderT r (ST s) a>_R
 +                ->_R <r>_R ->_R Sym (N:ST <s>_N <b>_R)
 +                     ; Sym (N:ReaderT <*>_N <r>_R <ST s>_R <b>_N)
 +                :: Coercible
 +                     (forall a b. (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b)
 +                     (forall a b. (a -> b) -> ReaderT r (ST s) a -> ReaderT r (ST s) b))
 +"SPEC $cliftA2 @(ST s) @_"
 +    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
 +      $fApplicativeReaderT_$cliftA2 @(ST s) @r $dApplicative
 +      = ($fApplicativeReaderT3 @s @r)
 +        `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N) (c ::~ <*>_N).
 +                <a -> b -> c>_R
 +                ->_R <ReaderT r (ST s) a>_R
 +                ->_R <ReaderT r (ST s) b>_R
 +                ->_R <r>_R ->_R Sym (N:ST <s>_N <c>_R)
 +                     ; Sym (N:ReaderT <*>_N <r>_R <ST s>_R <c>_N)
 +                :: Coercible
 +                     (forall a b c.
 +                      (a -> b -> c)
 +                      -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s c)
 +                     (forall a b c.
 +                      (a -> b -> c)
 +                      -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) c))
 +"SPEC $cp1Applicative @(ST s) @_"
 +    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
 +      $fApplicativeReaderT_$cp1Applicative @(ST s) @r $dApplicative
 +      = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
 +"SPEC $cp1Monad @(ST s) @_"
 +    forall (@s) (@r) ($dMonad :: Monad (ST s)).
 +      $fMonadReaderT_$cp1Monad @(ST s) @r $dMonad
 +      = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
 +"SPEC $cpure @(ST s) @_"
 +    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
 +      $fApplicativeReaderT_$cpure @(ST s) @r $dApplicative
 +      = ($fApplicativeReaderT5 @s @r)
 +        `cast` (forall (a ::~ <*>_N).
 +                <a>_R
 +                ->_R <r>_R ->_R Sym (N:ST <s>_N <a>_R)
 +                     ; Sym (N:ReaderT <*>_N <r>_R <ST s>_R <a>_N)
 +                :: Coercible
 +                     (forall a. a -> r -> STRep s a)
 +                     (forall a. a -> ReaderT r (ST s) a))
 +"SPEC $creturn @(ST s) @_"
 +    forall (@s) (@r) ($dMonad :: Monad (ST s)).
 +      $fMonadReaderT_$creturn @(ST s) @r $dMonad
 +      = ($fApplicativeReaderT5 @s @r)
 +        `cast` (forall (a ::~ <*>_N).
 +                <a>_R
 +                ->_R <r>_R ->_R Sym (N:ST <s>_N <a>_R)
 +                     ; Sym (N:ReaderT <*>_N <r>_R <ST s>_R <a>_N)
 +                :: Coercible
 +                     (forall a. a -> r -> STRep s a)
 +                     (forall a. a -> ReaderT r (ST s) a))
 +"SPEC $fApplicativeReaderT @(ST s) @_"
 +    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
 +      $fApplicativeReaderT @(ST s) @r $dApplicative
 +      = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r
 +"SPEC $fFunctorReaderT @(ST s) @_"
 +    forall (@s) (@r) ($dFunctor :: Functor (ST s)).
 +      $fFunctorReaderT @(ST s) @r $dFunctor
 +      = $fApplicativeReaderT_$s$fFunctorReaderT @s @r
 +"SPEC $fMonadReaderT @(ST s) @_"
 +    forall (@s) (@r) ($dMonad :: Monad (ST s)).
 +      $fMonadReaderT @(ST s) @r $dMonad
 +      = $fMonadAbstractIOSTReaderT_$s$fMonadReaderT @s @r
  "USPEC useAbstractMonad @(ReaderT Int (ST s))"
      forall (@s)
             ($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))).

testsuite/tests/simplCore/should_compile/all.T

@@ -544,6 +544,9 @@ test('T25883b', normal, compile_grep_core, [''])
  test('T25883c', normal, compile_grep_core, [''])
  test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="'])
 +test('T26588', normal, compile, ['-package containers -O'])
 +test('T26589', normal, compile, ['-O'])
++
  test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
  test('T25965', normal, compile, ['-O'])

utils/check-exact/ExactPrint.hs

@@ -19,6 +19,13 @@
  {-# LANGUAGE UndecidableInstances  #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance
  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-}
 +-- We switch off specialisation in this module. Otherwise we get lots of functions
 +-- specialised on lots of (GHC syntax tree) data types.  Compilation time allocation
 +-- (at least with -fpolymorphic-specialisation; see !15058) blows up from 17G to 108G.
 +-- Bad! ExactPrint is not a performance-critical module so it's not worth taking the
 +-- largely-fruitless hit in compile time.
 +{-# OPTIONS_GHC -fno-specialise #-}
++
  module ExactPrint
+   (
      ExactPrint(..)