GitLab

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

Commits:

93fc7265

by sheaf at 2025-11-06T21:33:24-05:00

Correct hasFixedRuntimeRep in matchExpectedFunTys

This commit fixes a bug in the representation-polymormorphism check in
GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put
the coercion resulting from hasFixedRuntimeRep in the wrong place,
leading to the Core Lint error reported in #26528.

The change is that we have to be careful when using 'mkWpFun': it
expects **both** the expected and actual argument types to have a
syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT]
in GHC.Tc.Types.Evidence.

On the way, this patch improves some of the commentary relating to
other usages of 'mkWpFun' in the compiler, in particular in the view
pattern case of 'tc_pat'. No functional changes, but some stylistic
changes to make the code more readable, and make it easier to understand
how we are upholding the WpFun-FRR-INVARIANT.

Fixes #26528

c052c724

by Simon Peyton Jones at 2025-11-06T21:34:06-05:00

Fix a horrible shadowing bug in implicit parameters

Fixes #26451.  The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.

This bug has been in GHC since 9.8!  But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.

26628a77

by Georgios Karachalias at 2025-11-07T11:21:02-05:00

Remove the `CoreBindings` constructor from `LinkablePart`

Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings
from being passed as input to getLinkDeps (which would previously
panic in this case).

Fixes #26497

19a1f0d9

by Sylvain Henry at 2025-11-07T11:21:26-05:00

Testsuite: pass ext-interp test way (#26552)

Note that some tests are still marked as broken with the ext-interp way
(see #26552 and #14335)

23 changed files:

compiler/GHC/Driver/Main.hs
compiler/GHC/Driver/Pipeline.hs
compiler/GHC/Linker/Deps.hs
compiler/GHC/Linker/Types.hs
compiler/GHC/Tc/Gen/Expr.hs
compiler/GHC/Tc/Gen/Pat.hs
compiler/GHC/Tc/Solver/Dict.hs
compiler/GHC/Tc/Solver/Monad.hs
compiler/GHC/Tc/Types/Evidence.hs
compiler/GHC/Tc/Utils/Instantiate.hs
compiler/GHC/Tc/Utils/Unify.hs
compiler/GHC/Unit/Home/ModInfo.hs
compiler/GHC/Unit/Module/Status.hs
compiler/GHC/Unit/Module/WholeCoreBindings.hs
libraries/base/tests/all.T
testsuite/driver/testlib.py
testsuite/tests/driver/T20696/all.T
testsuite/tests/driver/fat-iface/all.T
+ testsuite/tests/rep-poly/T26528.hs
testsuite/tests/rep-poly/all.T
testsuite/tests/splice-imports/all.T
+ testsuite/tests/typecheck/should_compile/T26451.hs
testsuite/tests/typecheck/should_compile/all.T

Changes:

compiler/GHC/Driver/Main.hs

@@ -277,6 +277,7 @@ import Data.Data hiding (Fixity, TyCon)
  import Data.Functor ((<&>))
  import Data.List ( nub, isPrefixOf, partition )
  import qualified Data.List.NonEmpty as NE
 +import Data.Traversable (for)
  import Control.Monad
  import Data.IORef
  import System.FilePath as FilePath
@@ -850,11 +851,11 @@ hscRecompStatus
          if | not (backendGeneratesCode (backend lcl_dflags)) -> do
                 -- No need for a linkable, we're good to go
                 msg UpToDate
 -               return $ HscUpToDate checked_iface emptyHomeModInfoLinkable
 +               return $ HscUpToDate checked_iface emptyRecompLinkables
             | not (backendGeneratesCodeForHsBoot (backend lcl_dflags))
             , IsBoot <- isBootSummary mod_summary -> do
                 msg UpToDate
 -               return $ HscUpToDate checked_iface emptyHomeModInfoLinkable
 +               return $ HscUpToDate checked_iface emptyRecompLinkables
             -- Always recompile with the JS backend when TH is enabled until
             -- #23013 is fixed.
@@ -883,7 +884,7 @@ hscRecompStatus
                 let just_o = justObjects <$> obj_linkable
                     bytecode_or_object_code
 -                      | gopt Opt_WriteByteCode lcl_dflags = justBytecode <$> definitely_bc
 +                      | gopt Opt_WriteByteCode lcl_dflags = justBytecode . Left <$> definitely_bc
                        | otherwise = (justBytecode <$> maybe_bc) `choose` just_o
@@ -900,13 +901,13 @@ hscRecompStatus
                     definitely_bc = bc_obj_linkable `prefer` bc_in_memory_linkable
                     -- If not -fwrite-byte-code, then we could use core bindings or object code if that's available.
 -                   maybe_bc = bc_in_memory_linkable `choose`
 -                              bc_obj_linkable `choose`
 -                              bc_core_linkable
 +                   maybe_bc = (Left <$> bc_in_memory_linkable) `choose`
 +                              (Left <$> bc_obj_linkable) `choose`
 +                              (Right <$> bc_core_linkable)
                     bc_result = if gopt Opt_WriteByteCode lcl_dflags
                                  -- If the byte-code artifact needs to be produced, then we certainly need bytecode.
 -                                then definitely_bc
 +                                then Left <$> definitely_bc
                                  else maybe_bc
                 trace_if (hsc_logger hsc_env)
@@ -1021,14 +1022,13 @@ checkByteCodeFromObject hsc_env mod_sum = do
  -- | Attempt to load bytecode from whole core bindings in the interface if they exist.
  -- This is a legacy code-path, these days it should be preferred to use the bytecode object linkable.
 -checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated Linkable)
 +checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated WholeCoreBindingsLinkable)
  checkByteCodeFromIfaceCoreBindings _hsc_env iface mod_sum = do
      let
        this_mod   = ms_mod mod_sum
        if_date    = fromJust $ ms_iface_date mod_sum
      case iface_core_bindings iface (ms_location mod_sum) of
 -      Just fi -> do
 -          return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
 +      Just fi -> return $ UpToDateItem (Linkable if_date this_mod fi)
        _ -> return $ outOfDateItemBecause MissingBytecode Nothing
  --------------------------------------------------------------
@@ -1142,20 +1142,22 @@ initWholeCoreBindings ::
    HscEnv ->
    ModIface ->
    ModDetails ->
 -  Linkable ->
 -  IO Linkable
 -initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do
 -  Linkable utc_time this_mod <$> mapM (go hsc_env) uls
 +  RecompLinkables ->
 +  IO HomeModLinkable
 +initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do
 +  bc' <- go bc
 +  pure $ HomeModLinkable bc' o
    where
 -    go hsc_env' = \case
 -      CoreBindings wcb -> do
 +    type_env = md_types details
++
 +    go :: RecompBytecodeLinkable -> IO (Maybe Linkable)
 +    go (NormalLinkable l) = pure l
 +    go (WholeCoreBindingsLinkable wcbl) =
 +      fmap Just $ for wcbl $ \wcb -> do
          add_iface_to_hpt iface details hsc_env
          bco <- unsafeInterleaveIO $
 -                       compileWholeCoreBindings hsc_env' type_env wcb
 -        pure (DotGBC bco)
 -      l -> pure l
+-
 -    type_env = md_types details
 +                       compileWholeCoreBindings hsc_env type_env wcb
 +        pure $ NE.singleton (DotGBC bco)
  -- | Hydrate interface Core bindings and compile them to bytecode.
  --

compiler/GHC/Driver/Pipeline.hs

@@ -109,6 +109,7 @@ import GHC.Unit.Env
  import GHC.Unit.Finder
  import GHC.Unit.Module.ModSummary
  import GHC.Unit.Module.ModIface
 +import GHC.Unit.Module.Status
  import GHC.Unit.Home.ModInfo
  import GHC.Unit.Home.PackageTable
@@ -249,8 +250,8 @@ compileOne' mHscMessage
     (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline
     -- See Note [ModDetails and --make mode]
     details <- initModDetails plugin_hsc_env iface
 -   linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)
 -   return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
 +   linkable' <- initWholeCoreBindings plugin_hsc_env iface details linkable
 +   return $! HomeModInfo iface details linkable'
   where lcl_dflags  = ms_hspp_opts summary
         location    = ms_location summary
@@ -759,7 +760,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do
             $ phaseIfFlag hsc_env flag def action
  -- | The complete compilation pipeline, from start to finish
 -fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
 +fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, RecompLinkables)
  fullPipeline pipe_env hsc_env pp_fn src_flavour = do
    (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn
    let hsc_env' = hscSetFlags dflags hsc_env
@@ -768,7 +769,7 @@ fullPipeline pipe_env hsc_env pp_fn src_flavour = do
    hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
  -- | Everything after preprocess
 -hscPipeline :: P m => PipeEnv ->  ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable)
 +hscPipeline :: P m => PipeEnv -> (HscEnv, ModSummary, HscRecompStatus) -> m (ModIface, RecompLinkables)
  hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
    case hsc_recomp_status of
      HscUpToDate iface mb_linkable -> return (iface, mb_linkable)
@@ -777,7 +778,7 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
        hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )
        hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction
 -hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable)
 +hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, RecompLinkables)
  hscBackendPipeline pipe_env hsc_env mod_sum result =
    if backendGeneratesCode (backend (hsc_dflags hsc_env)) then
      do
@@ -796,15 +797,15 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
        return res
    else
      case result of
 -      HscUpdate iface ->  return (iface, emptyHomeModInfoLinkable)
 -      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable
 +      HscUpdate iface ->  return (iface, emptyRecompLinkables)
 +      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyRecompLinkables
  hscGenBackendPipeline :: P m
    => PipeEnv
    -> HscEnv
    -> ModSummary
    -> HscBackendAction
 -  -> m (ModIface, HomeModLinkable)
 +  -> m (ModIface, RecompLinkables)
  hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
    let mod_name = moduleName (ms_mod mod_sum)
        src_flavour = (ms_hsc_src mod_sum)
@@ -812,7 +813,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
    (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)
    final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file
    final_linkable <-
 -    case final_fp of
 +    safeCastHomeModLinkable <$> case final_fp of
        -- No object file produced, bytecode or NoBackend
        Nothing -> return mlinkable
        Just o_fp -> do
@@ -936,7 +937,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
     as :: P m => Bool -> m (Maybe FilePath)
     as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
 -   objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk
 +   objFromLinkable (_, recompLinkables_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk
     objFromLinkable _ = Nothing
     fromPhase :: P m => Phase -> m (Maybe FilePath)

compiler/GHC/Linker/Deps.hs

@@ -33,7 +33,6 @@ import GHC.Utils.Error
  import GHC.Unit.Env
  import GHC.Unit.Finder
  import GHC.Unit.Module
 -import GHC.Unit.Module.WholeCoreBindings
  import GHC.Unit.Home.ModInfo
  import GHC.Iface.Errors.Types
@@ -206,10 +205,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
                DotO file ForeignObject -> pure (DotO file ForeignObject)
                DotA fp    -> panic ("adjust_ul DotA " ++ show fp)
                DotDLL fp  -> panic ("adjust_ul DotDLL " ++ show fp)
 -              DotGBC {}    -> pure part
 -              CoreBindings WholeCoreBindings {wcb_module} ->
 -                pprPanic "Unhydrated core bindings" (ppr wcb_module)
+-
 +              DotGBC {}  -> pure part
  {-

compiler/GHC/Linker/Types.hs

  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE LambdaCase #-}
 +{-# LANGUAGE DeriveTraversable #-}
  -----------------------------------------------------------------------------
  --
@@ -30,7 +31,9 @@ module GHC.Linker.Types
     , PkgsLoaded
     -- * Linkable
 -   , Linkable(..)
 +   , Linkable
 +   , WholeCoreBindingsLinkable
 +   , LinkableWith(..)
     , mkModuleByteCodeLinkable
     , LinkablePart(..)
     , LinkableObjectSort (..)
@@ -254,7 +257,7 @@ instance Outputable LoadedPkgInfo where
  -- | Information we can use to dynamically link modules into the compiler
 -data Linkable = Linkable
 +data LinkableWith parts = Linkable
    { linkableTime     :: !UTCTime
        -- ^ Time at which this linkable was built
        -- (i.e. when the bytecodes were produced,
@@ -263,9 +266,13 @@ data Linkable = Linkable
    , linkableModule   :: !Module
        -- ^ The linkable module itself
 -  , linkableParts :: NonEmpty LinkablePart
 +  , linkableParts :: parts
      -- ^ Files and chunks of code to link.
 - }
 + } deriving (Functor, Traversable, Foldable)
++
 +type Linkable = LinkableWith (NonEmpty LinkablePart)
++
 +type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings
  type LinkableSet = ModuleEnv Linkable
@@ -282,7 +289,7 @@ unionLinkableSet = plusModuleEnv_C go
        | linkableTime l1 > linkableTime l2 = l1
        | otherwise = l2
 -instance Outputable Linkable where
 +instance Outputable a => Outputable (LinkableWith a) where
    ppr (Linkable when_made mod parts)
       = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod)
         $$ nest 3 (ppr parts)
@@ -318,11 +325,6 @@ data LinkablePart
    | DotDLL FilePath
        -- ^ Dynamically linked library file (.so, .dll, .dylib)
 -  | CoreBindings WholeCoreBindings
 -      -- ^ Serialised core which we can turn into BCOs (or object files), or
 -      -- used by some other backend See Note [Interface Files with Core
 -      -- Definitions]
+-
    | DotGBC ModuleByteCode
      -- ^ A byte-code object, lives only in memory.
@@ -350,7 +352,6 @@ instance Outputable LinkablePart where
    ppr (DotA path)       = text "DotA" <+> text path
    ppr (DotDLL path)     = text "DotDLL" <+> text path
    ppr (DotGBC bco)      = text "DotGBC" <+> ppr bco
 -  ppr (CoreBindings {}) = text "CoreBindings"
  -- | Return true if the linkable only consists of native code (no BCO)
  linkableIsNativeCodeOnly :: Linkable -> Bool
@@ -391,7 +392,6 @@ isNativeCode = \case
    DotA {}         -> True
    DotDLL {}       -> True
    DotGBC {}       -> False
 -  CoreBindings {} -> False
  -- | Is the part a native library? (.so/.dll)
  isNativeLib :: LinkablePart -> Bool
@@ -400,7 +400,6 @@ isNativeLib = \case
    DotA {}         -> True
    DotDLL {}       -> True
    DotGBC {}       -> False
 -  CoreBindings {} -> False
  -- | Get the FilePath of linkable part (if applicable)
  linkablePartPath :: LinkablePart -> Maybe FilePath
@@ -408,7 +407,6 @@ linkablePartPath = \case
    DotO fn _       -> Just fn
    DotA fn         -> Just fn
    DotDLL fn       -> Just fn
 -  CoreBindings {} -> Nothing
    DotGBC {}       -> Nothing
  -- | Return the paths of all object code files (.o, .a, .so) contained in this
@@ -418,7 +416,6 @@ linkablePartNativePaths = \case
    DotO fn _       -> [fn]
    DotA fn         -> [fn]
    DotDLL fn       -> [fn]
 -  CoreBindings {} -> []
    DotGBC {}       -> []
  -- | Return the paths of all object files (.o) contained in this 'LinkablePart'.
@@ -427,7 +424,6 @@ linkablePartObjectPaths = \case
    DotO fn _ -> [fn]
    DotA _ -> []
    DotDLL _ -> []
 -  CoreBindings {} -> []
    DotGBC bco -> gbc_foreign_files bco
  -- | Retrieve the compiled byte-code from the linkable part.
@@ -444,12 +440,11 @@ linkableFilter f linkable = do
    Just linkable {linkableParts = new}
  linkablePartNative :: LinkablePart -> [LinkablePart]
 -linkablePartNative = \case
 -  u@DotO {}  -> [u]
 -  u@DotA {} -> [u]
 -  u@DotDLL {} -> [u]
 +linkablePartNative u = case u of
 +  DotO {}  -> [u]
 +  DotA {} -> [u]
 +  DotDLL {} -> [u]
    DotGBC bco -> [DotO f ForeignObject | f <- gbc_foreign_files bco]
 -  _ -> []
  linkablePartByteCode :: LinkablePart -> [LinkablePart]
  linkablePartByteCode = \case

compiler/GHC/Tc/Gen/Expr.hs

@@ -957,7 +957,7 @@ tcSynArgE :: CtOrigin
            -> SyntaxOpType                -- ^ shape it is expected to have
            -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
            -> TcM (a, HsWrapper)
 -           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
 +           -- ^ returns a wrapper :: (type of right shape) ~~> (type passed in)
  tcSynArgE orig op sigma_ty syn_ty thing_inside
    = do { (skol_wrap, (result, ty_wrapper))
             <- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty ->
@@ -978,10 +978,10 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside
             ; return (result, mkWpCastN list_co) }
      go rho_ty (SynFun arg_shape res_shape)
 -      = do { ( match_wrapper                         -- :: (arg_ty -> res_ty) "->" rho_ty
 +      = do { ( match_wrapper                         -- :: (arg_ty -> res_ty) ~~> rho_ty
               , ( ( (result, arg_ty, res_ty, op_mult)
 -                 , res_wrapper )                     -- :: res_ty_out "->" res_ty
 -               , arg_wrapper1, [], arg_wrapper2 ) )  -- :: arg_ty "->" arg_ty_out
 +                 , res_wrapper )                     -- :: res_ty_out ~~> res_ty
 +               , arg_wrapper1, [], arg_wrapper2 ) )  -- :: arg_ty ~~> arg_ty_out
                 <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
                    \ [ExpFunPatTy arg_ty] res_ty ->
                    do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
@@ -1031,7 +1031,7 @@ tcSynArgA :: CtOrigin
  tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
    = do { (match_wrapper, arg_tys, res_ty)
             <- matchActualFunTys herald orig (length arg_shapes) sigma_ty
 -              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
 +              -- match_wrapper :: sigma_ty ~~> (arg_tys -> res_ty)
         ; ((result, res_wrapper), arg_wrappers)
             <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
                tc_syn_arg    res_ty  res_shape  $ \ res_results ->
@@ -1061,12 +1061,12 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
             ; return (result, idHsWrapper) }
      tc_syn_arg res_ty SynRho thing_inside
        = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
 -               -- inst_wrap :: res_ty "->" rho_ty
 +               -- inst_wrap :: res_ty ~~> rho_ty
             ; result <- thing_inside [rho_ty]
             ; return (result, inst_wrap) }
      tc_syn_arg res_ty SynList thing_inside
        = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
 -               -- inst_wrap :: res_ty "->" rho_ty
 +               -- inst_wrap :: res_ty ~~> rho_ty
             ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty
                 -- list_co :: [elt_ty] ~N rho_ty
             ; result <- thing_inside [elt_ty]

compiler/GHC/Tc/Gen/Pat.hs

@@ -329,7 +329,7 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl
    -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
    | Just bndr_id <- sig_fn bndr_name   -- There is a signature
 -  = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id)
 +  = do { wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing exp_pat_ty) (idType bndr_id)
             -- See Note [Subsumption check at pattern variables]
         ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
         ; return (wrap, bndr_id) }
@@ -376,10 +376,12 @@ newLetBndr LetLclBndr name w ty
  newLetBndr (LetGblBndr prags) name w ty
    = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
 -tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
 --- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
 --- Used during typechecking patterns
 -tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
 +-- | A version of 'tcSubTypePat' specialised to 'GenSigCtxt'.
 +--
 +-- Used during typechecking of patterns.
 +tcSubTypePat_GenSigCtxt :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
 +tcSubTypePat_GenSigCtxt penv t1 t2 =
 +  tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
  {- Note [Subsumption check at pattern variables]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -618,111 +620,123 @@ tc_pat  :: Scaled ExpSigmaTypeFRR
          -> Checker (Pat GhcRn) (Pat GhcTc)
          -- ^ Translated pattern
 -tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
+-
 -  VarPat x (L l name) -> do
 -        { (wrap, id) <- tcPatBndr penv name pat_ty
 -        ; res <- tcCheckUsage name (scaledMult pat_ty) $
 -                              tcExtendIdEnv1 name id thing_inside
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
+-
 -  ParPat x pat -> do
 -        { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
 -        ; return (ParPat x pat', res) }
+-
 -  BangPat x pat -> do
 -        { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
 -        ; return (BangPat x pat', res) }
+-
 -  OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
 -    { let pats_list = NE.toList pats
 -    ; (pats_list', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats_list) penv pats_list (captureConstraints thing_inside)
 -    ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
 -    ; emitConstraints pat_ct
 -        -- captureConstraints/extendConstraints:
 -        --   like in Note [Hopping the LIE in lazy patterns]
 -    ; pat_ty <- expTypeToType (scaledThing pat_ty)
 -    ; return (OrPat pat_ty pats', res) }
+-
 -  LazyPat x pat -> do
 -        { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty
 -        ; (pat', (res, pat_ct))
 -                <- tc_lpat pat_ty (makeLazy penv) pat $
 -                   captureConstraints thing_inside
 -                -- Ignore refined penv', revert to penv
+-
 -        ; emitConstraints pat_ct
 -        -- captureConstraints/extendConstraints:
 -        --   see Note [Hopping the LIE in lazy patterns]
+-
 -        -- Check that the expected pattern type is itself lifted
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
+-
 -        ; return ((LazyPat x pat'), res) }
+-
 -  WildPat _ -> do
 -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
 -        ; res <- thing_inside
 -        ; pat_ty <- expTypeToType (scaledThing pat_ty)
 -        ; return (WildPat pat_ty, res) }
+-
 -  AsPat x (L nm_loc name) pat -> do
 -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
 -        ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
 -        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
 -                         tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
 -                                 penv pat thing_inside
 -            -- NB: if we do inference on:
 -            --          \ (y@(x::forall a. a->a)) = e
 -            -- we'll fail.  The as-pattern infers a monotype for 'y', which then
 -            -- fails to unify with the polymorphic type for 'x'.  This could
 -            -- perhaps be fixed, but only with a bit more work.
 -            --
 -            -- If you fix it, don't forget the bindInstsOfPatIds!
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
+-
 -  ViewPat _ expr pat -> do
 -        { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty
 -         --
 -         -- It should be possible to have view patterns at linear (or otherwise
 -         -- non-Many) multiplicity. But it is not clear at the moment what
 -         -- restriction need to be put in place, if any, for linear view
 -         -- patterns to desugar to type-correct Core.
+-
 -        ; (expr', expr_rho)    <- tcInferExpr IIF_ShallowRho expr
 -               -- IIF_ShallowRho: do not perform deep instantiation, regardless of
 -               -- DeepSubsumption (Note [View patterns and polymorphism])
 -               -- But we must do top-instantiation to expose the arrow to matchActualFunTy
+-
 -         -- Expression must be a function
 -        ; let herald = ExpectedFunTyViewPat $ unLoc expr
 -        ; (expr_co1, Scaled _mult inf_arg_ty, inf_res_sigma)
 -            <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho
 -               -- See Note [View patterns and polymorphism]
 -               -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma)
+-
 -         -- Check that overall pattern is more polymorphic than arg type
 -        ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
 -            -- expr_wrap2 :: pat_ty "->" inf_arg_ty
+-
 -         -- Pattern must have inf_res_sigma
 -        ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside
+-
 -        ; let Scaled w h_pat_ty = pat_ty
 -        ; pat_ty <- readExpType h_pat_ty
 -        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
 -                              (Scaled w pat_ty) inf_res_sigma
 -              -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
 -              --                (pat_ty -> inf_res_sigma)
 -              -- NB: pat_ty comes from matchActualFunTy, so it has a
 -              -- fixed RuntimeRep, as needed to call mkWpFun.
+-
 -              expr_wrap = expr_wrap2' <.> mkWpCastN expr_co1
+-
 -        ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
 +tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside =
++
 +  case ps_pat of
++
 +    VarPat x (L l name) -> do
 +      { (wrap, id) <- tcPatBndr penv name scaled_exp_pat_ty
 +      ; res <- tcCheckUsage name w_pat $ tcExtendIdEnv1 name id thing_inside
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
++
 +    ParPat x pat -> do
 +      { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
 +      ; return (ParPat x pat', res) }
++
 +    BangPat x pat -> do
 +      { (pat', res) <- tc_lpat scaled_exp_pat_ty penv pat thing_inside
 +      ; return (BangPat x pat', res) }
++
 +    OrPat _ pats -> do -- See Note [Implementation of OrPatterns], Typechecker (1)
 +      { let pats_list   = NE.toList pats
 +            pat_exp_tys = map (const scaled_exp_pat_ty) pats_list
 +      ; (pats_list', (res, pat_ct)) <- tc_lpats pat_exp_tys penv pats_list (captureConstraints thing_inside)
 +      ; let pats' = NE.fromList pats_list' -- tc_lpats preserves non-emptiness
 +      ; emitConstraints pat_ct
 +          -- captureConstraints/extendConstraints:
 +          --   like in Note [Hopping the LIE in lazy patterns]
 +      ; pat_ty <- expTypeToType exp_pat_ty
 +      ; return (OrPat pat_ty pats', res) }
++
 +    LazyPat x pat -> do
 +      { checkManyPattern LazyPatternReason (noLocA ps_pat) scaled_exp_pat_ty
 +      ; (pat', (res, pat_ct))
 +              <- tc_lpat scaled_exp_pat_ty (makeLazy penv) pat $
 +                 captureConstraints thing_inside
 +              -- Ignore refined penv', revert to penv
++
 +      ; emitConstraints pat_ct
 +      -- captureConstraints/extendConstraints:
 +      --   see Note [Hopping the LIE in lazy patterns]
++
 +      -- Check that the expected pattern type is itself lifted
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
++
 +      ; return ((LazyPat x pat'), res) }
++
 +    WildPat _ -> do
 +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
 +      ; res <- thing_inside
 +      ; pat_ty <- expTypeToType exp_pat_ty
 +      ; return (WildPat pat_ty, res) }
++
 +    AsPat x (L nm_loc name) pat -> do
 +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
 +      ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name scaled_exp_pat_ty)
 +      ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
 +                       tc_lpat (Scaled w_pat (mkCheckExpType $ idType bndr_id))
 +                               penv pat thing_inside
 +          -- NB: if we do inference on:
 +          --          \ (y@(x::forall a. a->a)) = e
 +          -- we'll fail.  The as-pattern infers a monotype for 'y', which then
 +          -- fails to unify with the polymorphic type for 'x'.  This could
 +          -- perhaps be fixed, but only with a bit more work.
 +          --
 +          -- If you fix it, don't forget the bindInstsOfPatIds!
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }
++
 +    ViewPat _ view_expr inner_pat -> do
++
 +       -- The pattern is a view pattern, 'pat = (view_expr -> inner_pat)'.
 +       -- First infer the type of 'view_expr'; the overall type of the pattern
 +       -- is the argument type of 'view_expr', and the inner pattern type is
 +       -- checked against the result type of 'view_expr'.
++
 +      { checkManyPattern ViewPatternReason (noLocA ps_pat) scaled_exp_pat_ty
 +          -- It should be possible to have view patterns at linear (or otherwise
 +          -- non-Many) multiplicity. But it is not clear at the moment what
 +          -- restrictions need to be put in place, if any, for linear view
 +          -- patterns to desugar to type-correct Core.
++
 +         -- Infer the type of 'view_expr'.
 +      ; (view_expr', view_expr_rho)  <- tcInferExpr IIF_ShallowRho view_expr
 +             -- IIF_ShallowRho: do not perform deep instantiation, regardless of
 +             -- DeepSubsumption (Note [View patterns and polymorphism])
 +             -- But we must do top-instantiation to expose the arrow to matchActualFunTy
++
 +        -- 'view_expr' must be a function; expose its argument/result types
 +        -- using 'matchActualFunTy'.
 +      ; let herald = ExpectedFunTyViewPat $ unLoc view_expr
 +      ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty)
 +          <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr)
 +               (1, view_expr_rho) view_expr_rho
 +             -- See Note [View patterns and polymorphism]
 +             -- view_expr_co1 :: view_expr_rho ~~> (view_arg_ty -> view_res_ty)
++
 +       -- Check that the overall pattern's type is more polymorphic than
 +       -- the view function argument type.
 +      ; view_expr_wrap2 <- tcSubTypePat_GenSigCtxt penv exp_pat_ty view_arg_ty
 +          -- view_expr_wrap2 :: pat_ty ~~> view_arg_ty
++
 +        -- The inner pattern must have type 'view_res_ty'.
 +      ; (inner_pat', res) <- tc_lpat (Scaled w_pat (mkCheckExpType view_res_ty)) penv inner_pat thing_inside
++
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; let view_expr_wrap2' =
 +              mkWpFun view_expr_wrap2 idHsWrapper
 +                (Scaled w_pat pat_ty) view_res_ty
 +            -- view_expr_wrap2' ::  (view_arg_ty -> view_res_ty)
 +            --                  ~~> (pat_ty -> view_res_ty)
 +            -- This satisfies WpFun-FRR-INVARIANT:
 +            --  'view_arg_ty' was returned by matchActualFunTy, hence FRR
 +            --  'pat_ty' was passed in and is an 'ExpSigmaTypeFRR'
++
 +            view_expr_wrap = view_expr_wrap2' <.> mkWpCastN view_expr_co1
++
 +      ; return $ (ViewPat pat_ty (mkLHsWrap view_expr_wrap view_expr') inner_pat', res) }
  {- Note [View patterns and polymorphism]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -748,93 +762,91 @@ Another example is #26331.
  -- Type signatures in patterns
  -- See Note [Pattern coercions] below
 -  SigPat _ pat sig_ty -> do
 -        { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
 -                                                            sig_ty (scaledThing pat_ty)
 -                -- Using tcExtendNameTyVarEnv is appropriate here
 -                -- because we're not really bringing fresh tyvars into scope.
 -                -- We're *naming* existing tyvars. Note that it is OK for a tyvar
 -                -- from an outer scope to mention one of these tyvars in its kind.
 -        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
 -                         tcExtendNameTyVarEnv tv_binds $
 -                         tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
 +    SigPat _ pat sig_ty -> do
 +      { (inner_ty, tv_binds, wcs, wrap) <-
 +          tcPatSig (inPatBind penv) sig_ty exp_pat_ty
 +              -- Using tcExtendNameTyVarEnv is appropriate here
 +              -- because we're not really bringing fresh tyvars into scope.
 +              -- We're *naming* existing tyvars. Note that it is OK for a tyvar
 +              -- from an outer scope to mention one of these tyvars in its kind.
 +      ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
 +                       tcExtendNameTyVarEnv tv_binds $
 +                       tc_lpat (Scaled w_pat $ mkCheckExpType inner_ty) penv pat thing_inside
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
  ------------------------
  -- Lists, tuples, arrays
    -- Necessarily a built-in list pattern, not an overloaded list pattern.
    -- See Note [Desugaring overloaded list patterns].
 -  ListPat _ pats -> do
 -        { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
 -        ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
 -                                     penv pats thing_inside
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; return (mkHsWrapPat coi
 -                         (ListPat elt_ty pats') pat_ty, res) }
+-
 -  TuplePat _ pats boxity -> do
 -        { let arity = length pats
 -              tc = tupleTyCon boxity arity
 -              -- NB: tupleTyCon does not flatten 1-tuples
 -              -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
 -        ; checkTupSize arity
 -        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
 -                                               penv (scaledThing pat_ty)
 -                     -- Unboxed tuples have RuntimeRep vars, which we discard:
 -                     -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
 -        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
 -                                           Boxed   -> arg_tys
 -        ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys)
 +    ListPat _ pats -> do
 +      { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv exp_pat_ty
 +      ; (pats', res) <- tcMultiple (tc_lpat (Scaled w_pat $ mkCheckExpType elt_ty))
                                     penv pats thing_inside
+-
 -        ; dflags <- getDynFlags
+-
 -        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 -        -- so that we can experiment with lazy tuple-matching.
 -        -- This is a pretty odd place to make the switch, but
 -        -- it was easy to do.
 -        ; let
 -              unmangled_result = TuplePat con_arg_tys pats' boxity
 -                                 -- pat_ty /= pat_ty iff coi /= IdCo
 -              possibly_mangled_result
 -                | gopt Opt_IrrefutableTuples dflags &&
 -                  isBoxed boxity   = LazyPat noExtField (noLocA unmangled_result)
 -                | otherwise        = unmangled_result
+-
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
 -        ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
 -        }
+-
 -  SumPat _ pat alt arity  -> do
 -        { let tc = sumTyCon arity
 -        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
 -                                               penv (scaledThing pat_ty)
 -        ; -- Drop levity vars, we don't care about them here
 -          let con_arg_tys = drop arity arg_tys
 -        ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
 -                                 penv pat thing_inside
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
 -                 , res)
 -        }
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; return (mkHsWrapPat coi
 +                       (ListPat elt_ty pats') pat_ty, res) }
++
 +    TuplePat _ pats boxity -> do
 +      { let arity = length pats
 +            tc = tupleTyCon boxity arity
 +            -- NB: tupleTyCon does not flatten 1-tuples
 +            -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
 +      ; checkTupSize arity
 +      ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
 +                   -- Unboxed tuples have RuntimeRep vars, which we discard:
 +                   -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
 +      ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
 +                                         Boxed   -> arg_tys
 +      ; (pats', res) <- tc_lpats (map (Scaled w_pat . mkCheckExpType) con_arg_tys)
 +                                 penv pats thing_inside
++
 +      ; dflags <- getDynFlags
++
 +      -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 +      -- so that we can experiment with lazy tuple-matching.
 +      -- This is a pretty odd place to make the switch, but
 +      -- it was easy to do.
 +      ; let
 +            unmangled_result = TuplePat con_arg_tys pats' boxity
 +                               -- pat_ty /= pat_ty iff coi /= IdCo
 +            possibly_mangled_result
 +              | gopt Opt_IrrefutableTuples dflags &&
 +                isBoxed boxity   = LazyPat noExtField (noLocA unmangled_result)
 +              | otherwise        = unmangled_result
++
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
 +      ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
 +      }
++
 +    SumPat _ pat alt arity  -> do
 +      { let tc = sumTyCon arity
 +      ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv exp_pat_ty
 +      ; -- Drop levity vars, we don't care about them here
 +        let con_arg_tys = drop arity arg_tys
 +      ; (pat', res) <- tc_lpat (Scaled w_pat $ mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
 +                               penv pat thing_inside
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
 +               , res)
 +      }
  ------------------------
  -- Data constructors
 -  ConPat _ con arg_pats ->
 -    tcConPat penv con pat_ty arg_pats thing_inside
 +    ConPat _ con arg_pats ->
 +      tcConPat penv con scaled_exp_pat_ty arg_pats thing_inside
  ------------------------
  -- Literal patterns
 -  LitPat x simple_lit -> do
 -        { let lit_ty = hsLitType simple_lit
 -        ; wrap   <- tc_sub_type penv (scaledThing pat_ty) lit_ty
 -        ; res    <- thing_inside
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
 -                 , res) }
 +    LitPat x simple_lit -> do
 +      { let lit_ty = hsLitType simple_lit
 +      ; wrap   <- tcSubTypePat_GenSigCtxt penv exp_pat_ty lit_ty
 +      ; res    <- thing_inside
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
 +               , res) }
  ------------------------
  -- Overloaded patterns: n, and n+k
@@ -854,31 +866,31 @@ Another example is #26331.
  -- where lit_ty is the type of the overloaded literal 5.
  --
  -- When there is no negation, neg_lit_ty and lit_ty are the same
 -  NPat _ (L l over_lit) mb_neg eq -> do
 -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
 -          -- It may be possible to refine linear pattern so that they work in
 -          -- linear environments. But it is not clear how useful this is.
 -        ; let orig = LiteralOrigin over_lit
 -        ; ((lit', mb_neg'), eq')
 -            <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny]
 -                          (mkCheckExpType boolTy) $
 -               \ [neg_lit_ty] _ ->
 -               let new_over_lit lit_ty = newOverloadedLit over_lit
 -                                           (mkCheckExpType lit_ty)
 -               in case mb_neg of
 -                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
 -                 Just neg -> -- Negative literal
 -                             -- The 'negate' is re-mappable syntax
 -                   second Just <$>
 -                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
 -                    \ [lit_ty] _ -> new_over_lit lit_ty)
 -                     -- applied to a closed literal: linearity doesn't matter as
 -                     -- literals are typed in an empty environment, hence have
 -                     -- all multiplicities.
+-
 -        ; res <- thing_inside
 -        ; pat_ty <- readExpType (scaledThing pat_ty)
 -        ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
 +    NPat _ (L l over_lit) mb_neg eq -> do
 +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
 +        -- It may be possible to refine linear pattern so that they work in
 +        -- linear environments. But it is not clear how useful this is.
 +      ; let orig = LiteralOrigin over_lit
 +      ; ((lit', mb_neg'), eq')
 +          <- tcSyntaxOp orig eq [SynType exp_pat_ty, SynAny]
 +                        (mkCheckExpType boolTy) $
 +             \ [neg_lit_ty] _ ->
 +             let new_over_lit lit_ty = newOverloadedLit over_lit
 +                                         (mkCheckExpType lit_ty)
 +             in case mb_neg of
 +               Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
 +               Just neg -> -- Negative literal
 +                           -- The 'negate' is re-mappable syntax
 +                 second Just <$>
 +                 (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
 +                  \ [lit_ty] _ -> new_over_lit lit_ty)
 +                   -- applied to a closed literal: linearity doesn't matter as
 +                   -- literals are typed in an empty environment, hence have
 +                   -- all multiplicities.
++
 +      ; res <- thing_inside
 +      ; pat_ty <- readExpType exp_pat_ty
 +      ; return (NPat pat_ty (L l lit') mb_neg' eq', res) }
  {-
  Note [NPlusK patterns]
@@ -904,68 +916,67 @@ AST is used for the subtraction operation.
  -}
  -- See Note [NPlusK patterns]
 -  NPlusKPat _ (L nm_loc name)
 -               (L loc lit) _ ge minus -> do
 -        { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty
 -        ; let pat_exp_ty = scaledThing pat_ty
 -              orig = LiteralOrigin lit
 -        ; (lit1', ge')
 -            <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho]
 -                                  (mkCheckExpType boolTy) $
 -               \ [lit1_ty] _ ->
 -               newOverloadedLit lit (mkCheckExpType lit1_ty)
 -        ; ((lit2', minus_wrap, bndr_id), minus')
 -            <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
 -               \ [lit2_ty, var_ty] _ ->
 -               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
 -                  ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
 -                                     tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
 -                           -- co :: var_ty ~ idType bndr_id
+-
 -                           -- minus_wrap is applicable to minus'
 -                  ; return (lit2', wrap, bndr_id) }
+-
 -        ; pat_ty <- readExpType pat_exp_ty
+-
 -        -- The Report says that n+k patterns must be in Integral
 -        -- but it's silly to insist on this in the RebindableSyntax case
 -        ; unlessM (xoptM LangExt.RebindableSyntax) $
 -          do { icls <- tcLookupClass integralClassName
 -             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
+-
 -        ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+-
 -        ; let minus'' = case minus' of
 -                          NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
 -                                   -- this should be statically avoidable
 -                                   -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
 -                          SyntaxExprTc { syn_expr = minus'_expr
 -                                       , syn_arg_wraps = minus'_arg_wraps
 -                                       , syn_res_wrap = minus'_res_wrap }
 -                            -> SyntaxExprTc { syn_expr = minus'_expr
 -                                            , syn_arg_wraps = minus'_arg_wraps
 -                                            , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
 -                             -- Oy. This should really be a record update, but
 -                             -- we get warnings if we try. #17783
 -              pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
 -                               ge' minus''
 -        ; return (pat', res) }
 +    NPlusKPat _ (L nm_loc name)
 +             (L loc lit) _ ge minus -> do
 +      { checkManyPattern OtherPatternReason (noLocA ps_pat) scaled_exp_pat_ty
 +      ; let orig = LiteralOrigin lit
 +      ; (lit1', ge')
 +          <- tcSyntaxOp orig ge [SynType exp_pat_ty, SynRho]
 +                                (mkCheckExpType boolTy) $
 +             \ [lit1_ty] _ ->
 +             newOverloadedLit lit (mkCheckExpType lit1_ty)
 +      ; ((lit2', minus_wrap, bndr_id), minus')
 +          <- tcSyntaxOpGen orig minus [SynType exp_pat_ty, SynRho] SynAny $
 +             \ [lit2_ty, var_ty] _ ->
 +             do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
 +                ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
 +                                   tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
 +                         -- co :: var_ty ~ idType bndr_id
++
 +                         -- minus_wrap is applicable to minus'
 +                ; return (lit2', wrap, bndr_id) }
++
 +      ; pat_ty <- readExpType exp_pat_ty
++
 +      -- The Report says that n+k patterns must be in Integral
 +      -- but it's silly to insist on this in the RebindableSyntax case
 +      ; unlessM (xoptM LangExt.RebindableSyntax) $
 +        do { icls <- tcLookupClass integralClassName
 +           ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
++
 +      ; res <- tcExtendIdEnv1 name bndr_id thing_inside
++
 +      ; let minus'' = case minus' of
 +                        NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
 +                                 -- this should be statically avoidable
 +                                 -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
 +                        SyntaxExprTc { syn_expr = minus'_expr
 +                                     , syn_arg_wraps = minus'_arg_wraps
 +                                     , syn_res_wrap = minus'_res_wrap }
 +                          -> SyntaxExprTc { syn_expr = minus'_expr
 +                                          , syn_arg_wraps = minus'_arg_wraps
 +                                          , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
 +                           -- Oy. This should really be a record update, but
 +                           -- we get warnings if we try. #17783
 +            pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
 +                             ge' minus''
 +      ; return (pat', res) }
  -- Here we get rid of it and add the finalizers to the global environment.
  -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
 -  SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
 +    SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
        { addModFinalizersWithLclEnv mod_finalizers
 -      ; tc_pat pat_ty penv pat thing_inside }
 +      ; tc_pat scaled_exp_pat_ty penv pat thing_inside }
 -  SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
 +    SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
 -  EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
 +    EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
 -  InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
 +    InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern"
 -  XPat (HsPatExpanded lpat rpat) -> do
 -    { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
 -    ; return (XPat $ ExpansionPat lpat rpat', res) }
 +    XPat (HsPatExpanded lpat rpat) -> do
 +      { (rpat', res) <- tc_pat scaled_exp_pat_ty penv rpat thing_inside
 +      ; return (XPat $ ExpansionPat lpat rpat', res) }
  {-
  Note [Hopping the LIE in lazy patterns]
@@ -1295,7 +1306,7 @@ tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside
          ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats
 -        ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty'
 +        ; wrap <- tcSubTypePat_GenSigCtxt penv (scaledThing pat_ty) ty'
          ; traceTc "tcPatSynPat" $
            vcat [ text "Pat syn:" <+> ppr pat_syn
@@ -1405,8 +1416,9 @@ matchExpectedConTy :: PatEnv
                         -- In the case of a data family, this would
                         -- mention the /family/ TyCon
                     -> TcM (HsWrapper, [TcSigmaType])
 --- See Note [Matching constructor patterns]
 --- Returns a wrapper : pat_ty "->" T ty1 ... tyn
 +-- ^ See Note [Matching constructor patterns]
 +--
 +-- Returns a wrapper : pat_ty ~~> T ty1 ... tyn
  matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
    | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
           -- Comments refer to Note [Matching constructor patterns]

compiler/GHC/Tc/Solver/Dict.hs

@@ -263,7 +263,9 @@ in two places:
  * In `updInertDicts`, in this module, when adding [G] (?x :: ty), remove any
    existing [G] (?x :: ty'), regardless of ty'.
 -* Wrinkle (SIP1): we must be careful of superclasses.  Consider
 +There are wrinkles:
++
 +* Wrinkle (SIP1): we must be careful of superclasses (#14218).  Consider
       f,g :: (?x::Int, C a) => a -> a
       f v = let ?x = 4 in g v
@@ -271,24 +273,31 @@ in two places:
    We must /not/ solve this from the Given (?x::Int, C a), because of
    the intervening binding for (?x::Int).  #14218.
 -  We deal with this by arranging that when we add [G] (?x::ty) we delete
 +  We deal with this by arranging that when we add [G] (?x::ty) we /delete/
    * from the inert_cans, and
    * from the inert_solved_dicts
    any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass
    with (?x::ty).  See Note [Local implicit parameters] in GHC.Core.Predicate.
 -  An important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
 -  But it could happen for `class xx => D xx where ...` and the constraint D
 -  (?x :: int).  This corner (constraint-kinded variables instantiated with
 -  implicit parameter constraints) is not well explored.
 +  An very important special case is constraint tuples like [G] (% ?x::ty, Eq a %).
++
 +  But it could also happen for `class xx => D xx where ...` and the constraint
 +  D (?x :: int); again see Note [Local implicit parameters].  This corner
 +  (constraint-kinded variables instantiated with implicit parameter constraints)
 +  is not well explored.
 -  Example in #14218, and #23761
 +  You might worry about whether deleting an /entire/ constraint just because
 +  a distant superclass has an implicit parameter might make another Wanted for
 +  that constraint un-solvable.  Indeed so. But for constraint tuples it doesn't
 +  matter -- their entire payload is their superclasses.  And the other case is
 +  the ill-explored corner above.
    The code that accounts for (SIP1) is in updInertDicts; in particular the call to
    GHC.Core.Predicate.mentionsIP.
  * Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts`
 -  as well as `inert_cans`.
 +  as well as `inert_cans` (#23761).
++
    You might think that wouldn't be necessary, because an element of
    `inert_solved_dicts` is never an implicit parameter (see
    Note [Solved dictionaries] in GHC.Tc.Solver.InertSet).
@@ -301,6 +310,19 @@ in two places:
    Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it
    happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`.
 +* Wrinkle (SIP3)
 +  - Note that for the inert dictionaries, `inert_cans`, we must /only/ delete
 +    existing /Givens/!  Deleting an existing Wanted led to #26451; we just never
 +    solved it!
++
 +  - In contrast, the solved dictionaries, `inert_solved_dicts`, are really like
 +    Givens; they may be "inherited" from outer scopes, so we must delete any
 +    solved dictionaries for this implicit parameter for /both/ Givens /and/
 +    Wanteds.
++
 +    Otherwise the new Given doesn't properly shadow those inherited solved
 +    dictionaries. Test T23761 showed this up.
++
  Example 1:
  Suppose we have (typecheck/should_compile/ImplicitParamFDs)

compiler/GHC/Tc/Solver/Monad.hs

@@ -377,28 +377,53 @@ in GHC.Tc.Solver.Dict.
  -}
  updInertDicts :: DictCt -> TcS ()
 -updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
 -  = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls  <+> ppr tys)
+-
 -       ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys
 -            -> -- For [G] ?x::ty, remove any dicts mentioning ?x,
 -              --    from /both/ inert_cans /and/ inert_solved_dicts (#23761)
 -               -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters]
 -               updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
 -               inerts { inert_cans         = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics
 -                      , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved }
 -            | otherwise
 -            -> return ()
 +updInertDicts dict_ct
 +  = do { traceTcS "Adding inert dict" (ppr dict_ct)
++
 +       -- For Given implicit parameters (only), delete any existing
 +       -- Givens for the same implicit parameter.
 +       -- See Note [Shadowing of implicit parameters]
 +       ; deleteGivenIPs dict_ct
++
         -- Add the new constraint to the inert set
         ; updInertCans (updDicts (addDict dict_ct)) }
++
 +deleteGivenIPs :: DictCt -> TcS ()
 +-- Special magic when adding a Given implicit parameter to the inert set
 +-- For [G] ?x::ty, remove any existing /Givens/ mentioning ?x,
 +--    from /both/ inert_cans /and/ inert_solved_dicts (#23761)
 +-- See Note [Shadowing of implicit parameters]
 +deleteGivenIPs (DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
 +  | isGiven ev
 +  , Just (str_ty, _) <- isIPPred_maybe cls tys
 +  = updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) ->
 +    inerts { inert_cans         = updDicts (filterDicts (keep_can str_ty)) ics
 +           , inert_solved_dicts = filterDicts (keep_solved str_ty) solved }
 +  | otherwise
 +  = return ()
    where
 -    -- Does this class constraint or any of its superclasses mention
 -    -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
 -    does_not_mention_ip_for :: Type -> DictCt -> Bool
 -    does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
 -      = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
 -        -- See Note [Using typesAreApart when calling mightMentionIP]
 -        -- in GHC.Core.Predicate
 +    keep_can, keep_solved :: Type -> DictCt -> Bool
 +    -- keep_can: we keep an inert dictionary UNLESS
 +    --   (1) it is a Given
 +    --   (2) it binds an implicit parameter (?str :: ty) for the given 'str'
 +    --       regardless of 'ty', possibly via its superclasses
 +    -- The test is a bit conservative, hence `mightMentionIP` and `typesAreApart`
 +    -- See Note [Using typesAreApart when calling mightMentionIP]
 +    -- in GHC.Core.Predicate
 +    --
 +    -- keep_solved: same as keep_can, but for /all/ constraints not just Givens
 +    --
 +    -- Why two functions?  See (SIP3) in Note [Shadowing of implicit parameters]
 +    keep_can str (DictCt { di_ev = ev, di_cls = cls, di_tys = tys })
 +      = not (isGiven ev                -- (1)
 +          && mentions_ip str cls tys)  -- (2)
 +    keep_solved str (DictCt { di_cls = cls, di_tys = tys })
 +      = not (mentions_ip str cls tys)
++
 +    -- mentions_ip: the inert constraint might provide evidence
 +    -- for an implicit parameter (?str :: ty) for the given 'str'
 +    mentions_ip str cls tys
 +      = mightMentionIP (not . typesAreApart str) (const True) cls tys
  updInertIrreds :: IrredCt -> TcS ()
  updInertIrreds irred

compiler/GHC/Tc/Types/Evidence.hs

@@ -197,29 +197,29 @@ that it is a no-op.  Here's our solution:
      * we /must/ optimise subtype-HsWrappers (that's the point of this Note!)
      * there is little point in attempting to optimise any other HsWrappers
 -Note [WpFun-RR-INVARIANT]
 -~~~~~~~~~~~~~~~~~~~~~~~~~
 +Note [WpFun-FRR-INVARIANT]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~
  Given
    wrap = WpFun wrap1 wrap2 sty1 ty2
    where:  wrap1 :: exp_arg ~~> act_arg
            wrap2 :: act_res ~~> exp_res
            wrap  :: (act_arg -> act_res) ~~> (exp_arg -> exp_res)
  we have
 -  WpFun-RR-INVARIANT:
 +  WpFun-FRR-INVARIANT:
        the input (exp_arg) and output (act_arg) types of `wrap1`
        both have a fixed runtime-rep
  Reason: We desugar wrap[e] into
      \(x:exp_arg). wrap2[ e wrap1[x] ]
 -And then, because of Note [Representation polymorphism invariants], we need:
 +And then, because of Note [Representation polymorphism invariants]:
    * `exp_arg` must have a fixed runtime rep,
      so that lambda obeys the the FRR rules
    * `act_arg` must have a fixed runtime rep,
 -    so the that application (e wrap1[x]) obeys the FRR tules
 +    so that the application (e wrap1[x]) obeys the FRR rules
 -Hence WpFun-INVARIANT.
 +Hence WpFun-FRR-INVARIANT.
  -}
  data HsWrapper
@@ -246,7 +246,7 @@ data HsWrapper
         -- (WpFun wrap1 wrap2 (w, t1) t2)[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ]
         --
         -- INVARIANT: both input and output types of `wrap1` have a fixed runtime-rep
 -       --            See Note [WpFun-RR-INVARIANT]
 +       --            See Note [WpFun-FRR-INVARIANT]
         --
         -- Typing rules:
         -- If    e     :: act_arg -> act_res
@@ -319,7 +319,7 @@ mkWpFun :: HsWrapper -> HsWrapper
  -- ^ Smart constructor for `WpFun`
  -- Just removes clutter and optimises some common cases.
  --
 --- PRECONDITION: same as Note [WpFun-RR-INVARIANT]
 +-- PRECONDITION: same as Note [WpFun-FRR-INVARIANT]
  --
  -- Unfortunately, we can't check PRECONDITION with an assertion here, because of
  -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete.

compiler/GHC/Tc/Utils/Instantiate.hs

@@ -277,7 +277,7 @@ skolemiseRequired skolem_info n_req sigma
  topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
  -- Instantiate outer invisible binders (both Inferred and Specified)
  -- If    top_instantiate ty = (wrap, inner_ty)
 --- then  wrap :: inner_ty "->" ty
 +-- then  wrap :: inner_ty ~~> ty
  -- NB: returns a type with no (=>),
  --     and no invisible forall at the top
  topInstantiate orig sigma

compiler/GHC/Tc/Utils/Unify.hs

@@ -66,7 +66,6 @@ module GHC.Tc.Utils.Unify (
  import GHC.Prelude
  import GHC.Hs
+-
  import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) )
  import GHC.Tc.Errors.Ppr   ( pprErrCtxtMsg )
  import GHC.Tc.Utils.Concrete
@@ -256,24 +255,24 @@ matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpected
  --       and res_ty is a RhoType
  -- NB: the returned type is top-instantiated; it's a RhoType
  matchActualFunTys herald ct_orig n_val_args_wanted top_ty
 -  = go n_val_args_wanted [] top_ty
 +  = go n_val_args_wanted top_ty
    where
 -    go n so_far fun_ty
 +    go n fun_ty
        | not (isRhoTy fun_ty)
        = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty
 -           ; (wrap2, arg_tys, res_ty) <- go n so_far rho
 +           ; (wrap2, arg_tys, res_ty) <- go n rho
             ; return (wrap2 <.> wrap1, arg_tys, res_ty) }
 -    go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
 +    go 0 fun_ty = return (idHsWrapper, [], fun_ty)
 -    go n so_far fun_ty
 -      = do { (co1, arg_ty1, res_ty1) <- matchActualFunTy herald Nothing
 -                                           (n_val_args_wanted, top_ty) fun_ty
 -           ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
 -           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
 -           -- NB: arg_ty1 comes from matchActualFunTy, so it has
 -           -- a syntactically fixed RuntimeRep
 -           ; return (wrap_fun2 <.> mkWpCastN co1, arg_ty1:arg_tys, res_ty) }
 +    go n fun_ty
 +      = do { (co1, arg1_ty_frr, res_ty1) <-
 +                matchActualFunTy herald Nothing (n_val_args_wanted, top_ty) fun_ty
 +           ; (wrap_res, arg_tys, res_ty) <- go (n-1) res_ty1
 +           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg1_ty_frr res_ty
 +              -- This call to mkWpFun satisfies WpFun-FRR-INVARIANT:
 +              -- 'arg1_ty_frr' comes from matchActualFunTy, so is FRR.
 +           ; return (wrap_fun2 <.> mkWpCastN co1, arg1_ty_frr:arg_tys, res_ty) }
  {-
  ************************************************************************
@@ -866,12 +865,30 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
        = assert (isVisibleFunArg af) $
          do { let arg_pos = arity - n_req + 1   -- 1 for the first argument etc
             ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
 -           ; let arg_sty_frr = Scaled mult arg_ty_frr
 -           ; (wrap_res, result) <- check (n_req - 1)
 -                                         (mkCheckExpFunPatTy arg_sty_frr : rev_pat_tys)
 +           ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr
 +           ; (res_wrap, result) <- check (n_req - 1)
 +                                         (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys)
                                           res_ty
 -           ; let wrap_arg = mkWpCastN arg_co
 -                 fun_wrap = mkWpFun wrap_arg wrap_res arg_sty_frr res_ty
++
 +            -- arg_co :: arg_ty ~ arg_ty_frr
 +            -- res_wrap :: act_res_ty ~~> res_ty
 +           ; let fun_wrap1 -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty_frr -> res_ty)
 +                   = mkWpFun idHsWrapper res_wrap scaled_arg_ty_frr res_ty
 +                       -- Satisfies WpFun-FRR-INVARIANT because arg_sty_frr is FRR
++
 +                 fun_wrap2 -- :: (arg_ty_frr -> res_ty) ~~> (arg_ty -> res_ty)
 +                   = mkWpCastN (mkFunCo Nominal af (mkNomReflCo mult) (mkSymCo arg_co) (mkNomReflCo res_ty))
++
 +                 fun_wrap -- :: (arg_ty_frr -> act_res_ty) ~~> (arg_ty -> res_ty)
 +                   = fun_wrap2 <.> fun_wrap1
++
 +-- NB: in the common case, 'arg_ty' is already FRR (in the sense of
 +--     Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete), hence 'arg_co' is 'Refl'.
 +--     Then 'fun_wrap' will collapse down to 'fun_wrap1'. This applies recursively;
 +--     as 'mkWpFun WpHole WpHole' is 'WpHole', this means that 'fun_wrap' will
 +--     typically just be 'WpHole'; no clutter.
 +--     This is important because 'matchExpectedFunTys' is called a lot.
++
             ; return (fun_wrap, result) }
      ----------------------------
@@ -1404,7 +1421,7 @@ tcSubTypeMono rn_expr act_ty exp_ty
  ------------------------
  tcSubTypePat :: CtOrigin -> UserTypeCtxt
 -            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
 +             -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
  -- Used in patterns; polarity is backwards compared
  --   to tcSubType
  -- If wrap = tc_sub_type_et t1 t2

compiler/GHC/Unit/Home/ModInfo.hs

@@ -3,13 +3,10 @@
  module GHC.Unit.Home.ModInfo
+    (
       HomeModInfo (..)
 -   , HomeModLinkable(..)
 +   , HomeModLinkable (..)
     , homeModInfoObject
     , homeModInfoByteCode
     , emptyHomeModInfoLinkable
 -   , justBytecode
 -   , justObjects
 -   , bytecodeAndObjects
+    )
  where
@@ -18,11 +15,9 @@ import GHC.Prelude
  import GHC.Unit.Module.ModIface
  import GHC.Unit.Module.ModDetails
 -import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly )
 +import GHC.Linker.Types ( Linkable )
  import GHC.Utils.Outputable
 -import GHC.Utils.Panic
+-
  -- | Information about modules in the package being compiled
  data HomeModInfo = HomeModInfo
@@ -68,22 +63,6 @@ data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
  instance Outputable HomeModLinkable where
    ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
 -justBytecode :: Linkable -> HomeModLinkable
 -justBytecode lm =
 -  assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
 -   $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
+-
 -justObjects :: Linkable -> HomeModLinkable
 -justObjects lm =
 -  assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
 -   $ emptyHomeModInfoLinkable { homeMod_object = Just lm }
+-
 -bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
 -bytecodeAndObjects bc o =
 -  assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
 -    (HomeModLinkable (Just bc) (Just o))
+-
+-
  {-
  Note [Home module build products]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/GHC/Unit/Module/Status.hs

 +{-# LANGUAGE LambdaCase #-}
++
  module GHC.Unit.Module.Status
 -   ( HscBackendAction(..), HscRecompStatus (..)
 +   ( HscBackendAction(..)
 +   , HscRecompStatus (..)
 +   , RecompLinkables (..)
 +   , RecompBytecodeLinkable (..)
 +   , emptyRecompLinkables
 +   , justBytecode
 +   , justObjects
 +   , bytecodeAndObjects
 +   , safeCastHomeModLinkable
+    )
  where
  import GHC.Prelude
  import GHC.Unit
 +import GHC.Unit.Home.ModInfo
  import GHC.Unit.Module.ModGuts
  import GHC.Unit.Module.ModIface
 +import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly )
++
  import GHC.Utils.Fingerprint
  import GHC.Utils.Outputable
 -import GHC.Unit.Home.ModInfo
 +import GHC.Utils.Panic
  -- | Status of a module in incremental compilation
  data HscRecompStatus
      -- | Nothing to do because code already exists.
 -    = HscUpToDate ModIface HomeModLinkable
 +    = HscUpToDate ModIface RecompLinkables
      -- | Recompilation of module, or update of interface is required. Optionally
      -- pass the old interface hash to avoid updating the existing interface when
      -- it has not changed.
@@ -41,6 +54,16 @@ data HscBackendAction
            -- changed.
+         }
 +-- | Linkables produced by @hscRecompStatus@. Might contain serialized core
 +-- which can be turned into BCOs (or object files), or used by some other
 +-- backend. See Note [Interface Files with Core Definitions].
 +data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompBytecodeLinkable
 +                                       , recompLinkables_object   :: !(Maybe Linkable) }
++
 +data RecompBytecodeLinkable
 +  = NormalLinkable !(Maybe Linkable)
 +  | WholeCoreBindingsLinkable !WholeCoreBindingsLinkable
++
  instance Outputable HscRecompStatus where
    ppr HscUpToDate{} = text "HscUpToDate"
    ppr HscRecompNeeded{} = text "HscRecompNeeded"
@@ -48,3 +71,37 @@ instance Outputable HscRecompStatus where
  instance Outputable HscBackendAction where
    ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi))
    ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml
++
 +instance Outputable RecompLinkables where
 +  ppr (RecompLinkables l1 l2) = ppr l1 $$ ppr l2
++
 +instance Outputable RecompBytecodeLinkable where
 +  ppr (NormalLinkable lm) = text "NormalLinkable:" <+> ppr lm
 +  ppr (WholeCoreBindingsLinkable lm) = text "WholeCoreBindingsLinkable:" <+> ppr lm
++
 +emptyRecompLinkables :: RecompLinkables
 +emptyRecompLinkables = RecompLinkables (NormalLinkable Nothing) Nothing
++
 +safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables
 +safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable bc) o
++
 +justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
 +justBytecode = \case
 +  Left lm ->
 +    assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
 +      $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
 +  Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
++
 +justObjects :: Linkable -> RecompLinkables
 +justObjects lm =
 +  assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
 +    $ emptyRecompLinkables { recompLinkables_object = Just lm }
++
 +bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
 +bytecodeAndObjects either_bc o = case either_bc of
 +  Left bc ->
 +    assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
 +      $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
 +  Right bc ->
 +    assertPpr (linkableIsNativeCodeOnly o) (ppr o)
 +      $ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)

compiler/GHC/Unit/Module/WholeCoreBindings.hs

@@ -130,6 +130,9 @@ data WholeCoreBindings = WholeCoreBindings
              , wcb_foreign :: IfaceForeign
+             }
 +instance Outputable WholeCoreBindings where
 +  ppr (WholeCoreBindings {}) = text "WholeCoreBindings"
++
  {-
  Note [Foreign stubs and TH bytecode linking]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

libraries/base/tests/all.T

@@ -80,7 +80,7 @@ test('length001',
       # excessive amounts of stack space. So we specifically set a low
       # stack limit and mark it as failing under a few conditions.
       [extra_run_opts('+RTS -K8m -RTS'),
 -     expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']),
 +     expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc', 'ext-interp']),
       # JS doesn't support stack limit so the test sometimes passes just fine. Therefore the test is
       # marked as fragile.
       when(js_arch(), fragile(22921))],

testsuite/driver/testlib.py

@@ -352,6 +352,9 @@ def req_plugins( name, opts ):
      """
      req_interp(name, opts)
 +    # Plugins aren't supported with the external interpreter (#14335)
 +    expect_broken_for(14335,['ext-interp'])(name,opts)
++
      if config.cross:
          opts.skip = True

testsuite/tests/driver/T20696/all.T

  test('T20696', [extra_files(['A.hs', 'B.hs', 'C.hs'])
 +               , expect_broken_for(26552, ['ext-interp'])
                 , unless(ghc_dynamic(), skip)], multimod_compile, ['A', ''])
  test('T20696-static', [extra_files(['A.hs', 'B.hs', 'C.hs'])
                 , when(ghc_dynamic(), skip)], multimod_compile, ['A', ''])

testsuite/tests/driver/fat-iface/all.T

@@ -9,12 +9,12 @@ test('fat010', [req_th,extra_files(['THA.hs', 'THB.hs', 'THC.hs']), copy_files],
  # Check linking works when using -fbyte-code-and-object-code
  test('fat011', [req_th, extra_files(['FatMain.hs', 'FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatMain', '-fbyte-code-and-object-code -fprefer-byte-code'])
  # Check that we use interpreter rather than enable dynamic-too if needed for TH
 -test('fat012', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code'])
 +test('fat012', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fprefer-byte-code'])
  # Check that no objects are generated if using -fno-code and -fprefer-byte-code
  test('fat013', [req_th, req_bco, extra_files(['FatTH.hs', 'FatQuote.hs'])], multimod_compile, ['FatTH', '-fno-code -fprefer-byte-code'])
  # When using interpreter should not produce objects
  test('fat014', [req_th, extra_files(['FatTH.hs', 'FatQuote.hs']), extra_run_opts('-fno-code')], ghci_script, ['fat014.script'])
 -test('fat015', [req_th, unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface'])
 +test('fat015', [req_th, expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(['FatQuote.hs', 'FatQuote1.hs', 'FatQuote2.hs', 'FatTH1.hs', 'FatTH2.hs', 'FatTHTop.hs'])], multimod_compile, ['FatTHTop', '-fno-code -fwrite-interface'])
  test('T22807', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807A.hs', 'T22807B.hs'])]
               , makefile_test, ['T22807'])
  test('T22807_ghci', [req_th, unless(ghc_dynamic(), skip), extra_files(['T22807_ghci.hs'])]

testsuite/tests/rep-poly/T26528.hs

 +{-# LANGUAGE GHC2024, TypeFamilies #-}
++
 +module T26528 where
++
 +import Data.Kind
 +import GHC.Exts
++
 +type F :: Type -> RuntimeRep
 +type family F a where
 +  F Int = LiftedRep
++
 +g :: forall (r::RuntimeRep).
 +     (forall (a :: TYPE r). a -> forall b. b -> b) -> Int
 +g _ = 3
 +{-# NOINLINE g #-}
++
 +foo = g @(F Int) (\x y -> y)

testsuite/tests/rep-poly/all.T

@@ -42,6 +42,7 @@ test('T23883b', normal, compile_fail, [''])
  test('T23883c', normal, compile_fail, [''])
  test('T23903', normal, compile_fail, [''])
  test('T26107', js_broken(22364), compile, ['-O'])
 +test('T26528', normal, compile, [''])
  test('EtaExpandDataCon', normal, compile, ['-O'])
  test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])

testsuite/tests/splice-imports/all.T

@@ -9,7 +9,7 @@ test('SI03', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI03', '-v0']
  test('SI04', [extra_files(["SI01A.hs"])], multimod_compile, ['SI04', '-v0'])
  test('SI05', [extra_files(["SI01A.hs"])], multimod_compile_fail, ['SI05', '-v0'])
  test('SI06', [extra_files(["SI01A.hs"])], multimod_compile, ['SI06', '-v0'])
 -test('SI07', [unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code'])
 +test('SI07', [expect_broken_for(26552, ['ext-interp']), unless(ghc_dynamic(), skip), extra_files(["SI05A.hs"])], multimod_compile, ['SI07', '-fwrite-interface -fno-code'])
  # Instance tests
  test('SI08', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile_fail, ['SI08', '-v0'])
  test('SI09', [extra_files(["ClassA.hs", "InstanceA.hs"])], multimod_compile, ['SI09', '-v0'])

testsuite/tests/typecheck/should_compile/T26451.hs

 +{-# LANGUAGE ImplicitParams, TypeFamilies, FunctionalDependencies, ScopedTypeVariables #-}
++
 +module T26451 where
++
 +type family F a
 +type instance F Bool = [Char]
++
 +class C a b | b -> a
 +instance C Bool Bool
 +instance C Char Char
++
 +eq :: forall a b. C a b => a -> b -> ()
 +eq p q = ()
++
 +g :: a -> F a
 +g = g
++
 +f (x::tx) (y::ty)   -- x :: alpha y :: beta
 +  = let ?v = g x   -- ?ip :: F alpha
 +      in (?v::[ty], eq x True)
++
++
 +{- tx, and ty are unification variables
++
 +Inert: [G] dg :: IP "v" (F tx)
 +       [W] dw :: IP "v" [ty]
 +Work-list: [W] dc1 :: C tx Bool
 +           [W] dc2 :: C ty Char
++
 +* Solve dc1, we get tx := Bool from fundep
 +* Kick out dg
 +* Solve dg to get [G] dc : IP "v" [Char]
 +* Add that new dg to the inert set: that simply deletes dw!!!
 +-}

testsuite/tests/typecheck/should_compile/all.T

@@ -955,3 +955,4 @@ test('T26376', normal, compile, [''])
  test('T26457', normal, compile, [''])
  test('T17705', normal, compile, [''])
  test('T14745', normal, compile, [''])
 +test('T26451', normal, compile, [''])