Compare revisions

Ben Gamari · Andreas Klebinger · Marge Bot · Matthew Pickering · Marge Bot · Ben Gamari
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -911,7 +911,8 @@ pages:
 .x86_64-linux-ubuntu20_04-cross_wasm32-wasi-release:
  stage: full-build
  rules:
-    - when: always
+    # See #22664 to see what needs to be done to bring this up to the validate pipeline standards.
+    - if: $NIGHTLY
  tags:
    - x86_64-linux
  image: registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-ubuntu20_04:$DOCKER_REV
@@ -953,7 +954,7 @@ pages:
    - cat ci-timings
  artifacts:
-    expire_in: 1 year
+    expire_in: 8 weeks
    paths:
      - ghc-x86_64-linux-ubuntu20_04-cross_wasm32-wasi-int_$BIGNUM_BACKEND-release.tar.xz
    when: always

--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -2282,7 +2282,8 @@ wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendI
    buildIdKey, foldrIdKey, recSelErrorIdKey,
    seqIdKey, eqStringIdKey,
    noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,
-    runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
+    impossibleErrorIdKey, impossibleConstraintErrorIdKey,
+    patErrorIdKey, voidPrimIdKey,
    realWorldPrimIdKey, recConErrorIdKey,
    unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,
    unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,
@@ -2290,37 +2291,38 @@ wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendI
    absentSumFieldErrorIdKey, cstringLengthIdKey
    :: Unique
-wildCardKey                   = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
+wildCardKey                    = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
-absentErrorIdKey              = mkPreludeMiscIdUnique  1
+absentErrorIdKey               = mkPreludeMiscIdUnique  1
-augmentIdKey                  = mkPreludeMiscIdUnique  2
+absentConstraintErrorIdKey     = mkPreludeMiscIdUnique  2
-appendIdKey                   = mkPreludeMiscIdUnique  3
+augmentIdKey                   = mkPreludeMiscIdUnique  3
-buildIdKey                    = mkPreludeMiscIdUnique  4
+appendIdKey                    = mkPreludeMiscIdUnique  4
-absentConstraintErrorIdKey    = mkPreludeMiscIdUnique  5
+buildIdKey                     = mkPreludeMiscIdUnique  5
-foldrIdKey                    = mkPreludeMiscIdUnique  6
+foldrIdKey                     = mkPreludeMiscIdUnique  6
-recSelErrorIdKey              = mkPreludeMiscIdUnique  7
+recSelErrorIdKey               = mkPreludeMiscIdUnique  7
-seqIdKey                      = mkPreludeMiscIdUnique  8
+seqIdKey                       = mkPreludeMiscIdUnique  8
-absentSumFieldErrorIdKey      = mkPreludeMiscIdUnique  9
+absentSumFieldErrorIdKey       = mkPreludeMiscIdUnique  9
-eqStringIdKey                 = mkPreludeMiscIdUnique 10
+eqStringIdKey                  = mkPreludeMiscIdUnique 10
-noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 11
+noMethodBindingErrorIdKey      = mkPreludeMiscIdUnique 11
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
+nonExhaustiveGuardsErrorIdKey  = mkPreludeMiscIdUnique 12
-runtimeErrorIdKey             = mkPreludeMiscIdUnique 13
+impossibleErrorIdKey           = mkPreludeMiscIdUnique 13
-patErrorIdKey                 = mkPreludeMiscIdUnique 14
+impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14
-realWorldPrimIdKey            = mkPreludeMiscIdUnique 15
+patErrorIdKey                  = mkPreludeMiscIdUnique 15
-recConErrorIdKey              = mkPreludeMiscIdUnique 16
+realWorldPrimIdKey             = mkPreludeMiscIdUnique 16
+recConErrorIdKey               = mkPreludeMiscIdUnique 17
-unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 17
-unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 18
+unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 18
-unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 19
+unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 19
+unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 20
-unpackCStringIdKey            = mkPreludeMiscIdUnique 20
-unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 21
+unpackCStringIdKey            = mkPreludeMiscIdUnique 21
-unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 22
+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 22
+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 23
-voidPrimIdKey                 = mkPreludeMiscIdUnique 23
-typeErrorIdKey                = mkPreludeMiscIdUnique 24
+voidPrimIdKey                 = mkPreludeMiscIdUnique 24
-divIntIdKey                   = mkPreludeMiscIdUnique 25
+typeErrorIdKey                = mkPreludeMiscIdUnique 25
-modIntIdKey                   = mkPreludeMiscIdUnique 26
+divIntIdKey                   = mkPreludeMiscIdUnique 26
-cstringLengthIdKey            = mkPreludeMiscIdUnique 27
+modIntIdKey                   = mkPreludeMiscIdUnique 27
+cstringLengthIdKey            = mkPreludeMiscIdUnique 28
 concatIdKey, filterIdKey, zipIdKey,
    bindIOIdKey, returnIOIdKey, newStablePtrIdKey,

--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -32,7 +32,7 @@ templateHaskellNames :: [Name]
 templateHaskellNames = [
    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
-    mkNameSName,
+    mkNameSName, mkNameQName,
    mkModNameName,
    liftStringName,
    unTypeName, unTypeCodeName,
@@ -216,7 +216,7 @@ modNameTyConName       = thTc (fsLit "ModName")        modNameTyConKey
 returnQName, bindQName, sequenceQName, newNameName, liftName,
    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
-    unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name
+    unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name
 returnQName    = thFun (fsLit "returnQ")   returnQIdKey
 bindQName      = thFun (fsLit "bindQ")     bindQIdKey
 sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
@@ -228,6 +228,7 @@ mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
 mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
 mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
+mkNameQName    = thFun (fsLit "mkNameQ")    mkNameQIdKey
 mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey
 mkModNameName  = thFun (fsLit "mkModName")  mkModNameIdKey
 unTypeName     = thFun (fsLit "unType")     unTypeIdKey
@@ -742,7 +743,7 @@ incoherentDataConKey   = mkPreludeDataConUnique 212
 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
-    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique
+    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique
 returnQIdKey        = mkPreludeMiscIdUnique 200
 bindQIdKey          = mkPreludeMiscIdUnique 201
 sequenceQIdKey      = mkPreludeMiscIdUnique 202
@@ -759,6 +760,7 @@ unTypeCodeIdKey      = mkPreludeMiscIdUnique 212
 liftTypedIdKey        = mkPreludeMiscIdUnique 214
 mkModNameIdKey        = mkPreludeMiscIdUnique 215
 unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216
+mkNameQIdKey         = mkPreludeMiscIdUnique 217
 -- data Lit = ...

--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -44,7 +44,7 @@ module GHC.Core.Make (
        -- * Error Ids
        mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
-        rEC_CON_ERROR_ID, rUNTIME_ERROR_ID,
+        rEC_CON_ERROR_ID,
        nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
        pAT_ERROR_ID, rEC_SEL_ERROR_ID,
        tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
@@ -58,6 +58,7 @@ import GHC.Types.Var  ( EvVar, setTyVarUnique, visArgConstraintLike )
 import GHC.Types.TyThing
 import GHC.Types.Id.Info
 import GHC.Types.Cpr
+import GHC.Types.Basic( TypeOrConstraint(..) )
 import GHC.Types.Demand
 import GHC.Types.Name      hiding ( varName )
 import GHC.Types.Literal
@@ -847,7 +848,9 @@ mkJustExpr ty val = mkConApp justDataCon [Type ty, val]
 -}
 mkRuntimeErrorApp
-        :: Id           -- Should be of type (forall a. Addr# -> a)
+        :: Id           -- Should be of type
+                        --   forall (r::RuntimeRep) (a::TYPE r). Addr# -> a
+                        --      or (a :: CONSTRAINT r)
                        --      where Addr# points to a UTF8 encoded string
        -> Type         -- The type to instantiate 'a'
        -> String       -- The string to print
@@ -859,10 +862,6 @@ mkRuntimeErrorApp err_id res_ty err_msg
  where
    err_string = Lit (mkLitString err_msg)
-mkImpossibleExpr :: Type -> CoreExpr
-mkImpossibleExpr res_ty
-  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
 {-
 ************************************************************************
 *                                                                      *
@@ -884,25 +883,23 @@ crash).
 errorIds :: [Id]
 errorIds
-  = [ rUNTIME_ERROR_ID,
+  = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID,
-      nON_EXHAUSTIVE_GUARDS_ERROR_ID,
      nO_METHOD_BINDING_ERROR_ID,
      pAT_ERROR_ID,
      rEC_CON_ERROR_ID,
      rEC_SEL_ERROR_ID,
-      aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID,
+      iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID,
+      aBSENT_ERROR_ID,  aBSENT_CONSTRAINT_ERROR_ID,
      aBSENT_SUM_FIELD_ERROR_ID,
      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
      ]
-recSelErrorName, runtimeErrorName :: Name
+recSelErrorName, recConErrorName, patErrorName :: Name
-recConErrorName, patErrorName :: Name
 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
 typeErrorName :: Name
 absentSumFieldErrorName :: Name
 recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
-runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID
 recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
 patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
 typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID
@@ -915,16 +912,15 @@ nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
 err_nm :: String -> Unique -> Id -> Name
 err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
-rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id
+rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id
 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
 tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
-rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
+rEC_SEL_ERROR_ID                = mkRuntimeErrorId TypeLike recSelErrorName
-rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
+rEC_CON_ERROR_ID                = mkRuntimeErrorId TypeLike recConErrorName
-rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
+pAT_ERROR_ID                    = mkRuntimeErrorId TypeLike patErrorName
-pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId TypeLike noMethodBindingErrorName
-nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName
-nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
+tYPE_ERROR_ID                   = mkRuntimeErrorId TypeLike typeErrorName
-tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
 -- Note [aBSENT_SUM_FIELD_ERROR_ID]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1038,30 +1034,6 @@ mkExceptionId name
      (divergingIdInfo [] `setCafInfo` NoCafRefs)
         -- See Note [Wired-in exceptions are not CAFfy]
-mkRuntimeErrorId :: Name -> Id
-- Error function
--   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
--   with arity: 1
-- which diverges after being given one argument
-- The Addr# is expected to be the address of
--   a UTF8-encoded error string
-mkRuntimeErrorId name
- = mkVanillaGlobalWithInfo name runtimeErrorTy (divergingIdInfo [evalDmd])
-     -- Do *not* mark them as NoCafRefs, because they can indeed have
-     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
-     -- which has some CAFs
-     -- In due course we may arrange that these error-y things are
-     -- regarded by the GC as permanently live, in which case we
-     -- can give them NoCaf info.  As it is, any function that calls
-     -- any pc_bottoming_Id will itself have CafRefs, which bloats
-     -- SRTs.
-runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
--   See Note [Error and friends have an "open-tyvar" forall]
-runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
-                                 (mkVisFunTyMany addrPrimTy openAlphaTy)
 -- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that
 -- throws an (imprecise) exception after being supplied one value arg for every
 -- argument 'Demand' in the list. The demands end up in the demand signature.
@@ -1089,6 +1061,56 @@ Notice the runtime-representation polymorphism. This ensures that
 This is OK because it never returns, so the return type is irrelevant.
+************************************************************************
+*                                                                      *
+                     iMPOSSIBLE_ERROR_ID
+*                                                                      *
+************************************************************************
+-}
+iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id
+iMPOSSIBLE_ERROR_ID            = mkRuntimeErrorId TypeLike       impossibleErrorName
+iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName
+impossibleErrorName, impossibleConstraintErrorName :: Name
+impossibleErrorName           = err_nm "impossibleError"
+                                impossibleErrorIdKey iMPOSSIBLE_ERROR_ID
+impossibleConstraintErrorName = err_nm "impossibleConstraintError"
+                                impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID
+mkImpossibleExpr :: Type -> String -> CoreExpr
+mkImpossibleExpr res_ty str
+  = mkRuntimeErrorApp err_id res_ty str
+  where    -- See Note [Type vs Constraint for error ids]
+    err_id | isConstraintLikeKind (typeKind res_ty) = iMPOSSIBLE_CONSTRAINT_ERROR_ID
+           | otherwise                              = iMPOSSIBLE_ERROR_ID
+{- Note [Type vs Constraint for error ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need both
+  iMPOSSIBLE_ERROR_ID            :: forall (r::RuntimeRep) (a::TYPE r).       Addr# -> a
+  iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a
+because we don't have polymorphism over TYPE vs CONSTRAINT.  You
+might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in
+practice, but it is: see #22634.  So:
+* In Control.Exception.Base we have
+      impossibleError           :: forall (a::Type). Addr# -> a
+      impossibleConstraintError :: forall (a::Type). Addr# -> a
+  This generates the code for `impossibleError`, but because they are wired in
+  the interface file definitions are never looked at (indeed, they don't
+  even get serialised).
+* In this module GHC.Core.Make we define /wired-in/ Ids for
+      iMPOSSIBLE_ERROR_ID
+      iMPOSSIBLE_CONSTRAINT_ERROR_ID
+   with the desired above types (i.e. runtime-rep polymorphic, and returning a
+   constraint for the latter.
+Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID
 ************************************************************************
 *                                                                      *
                     aBSENT_ERROR_ID
@@ -1176,6 +1198,7 @@ be relying on anything from it.
 --   absentConstraintError :: forall (a :: Constraint). Addr# -> a
 -- We don't have polymorphism over TypeOrConstraint!
 -- mkAbsentErrorApp chooses which one to use, based on the kind
+-- See Note [Type vs Constraint for error ids]
 mkAbsentErrorApp :: Type         -- The type to instantiate 'a'
                 -> String       -- The string to print
@@ -1193,29 +1216,69 @@ absentErrorName
   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError")
      absentErrorIdKey aBSENT_ERROR_ID
-absentConstraintErrorName
+absentConstraintErrorName   -- See Note [Type vs Constraint for error ids]
   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError")
      absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID
 aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id
 aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
- = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info
+ = mk_runtime_error_id absentErrorName absent_ty
 where
   -- absentError :: forall (a :: Type). Addr# -> a
   absent_ty = mkSpecForAllTys [alphaTyVar] $
               mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar)
   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
   -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils
-   id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!
 aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
- = mkVanillaGlobalWithInfo absentConstraintErrorName absent_ty id_info
+ = mk_runtime_error_id absentConstraintErrorName absent_ty
+   -- See Note [Type vs Constraint for error ids]
 where
   -- absentConstraintError :: forall (a :: Constraint). Addr# -> a
   absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $
               mkFunTy visArgConstraintLike ManyTy
                       addrPrimTy (mkTyVarTy alphaConstraintTyVar)
-   id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!
+{-
+************************************************************************
+*                                                                      *
+                     mkRuntimeErrorId
+*                                                                      *
+************************************************************************
+-}
+mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id
+-- Error function
+--   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
+--   with arity: 1
+-- which diverges after being given one argument
+-- The Addr# is expected to be the address of
+--   a UTF8-encoded error string
+mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc)
+mk_runtime_error_id :: Name -> Type -> Id
+mk_runtime_error_id name ty
+ = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd])
+     -- Do *not* mark them as NoCafRefs, because they can indeed have
+     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
+     -- which has some CAFs
+     -- In due course we may arrange that these error-y things are
+     -- regarded by the GC as permanently live, in which case we
+     -- can give them NoCaf info.  As it is, any function that calls
+     -- any pc_bottoming_Id will itself have CafRefs, which bloats
+     -- SRTs.
+mkRuntimeErrorTy :: TypeOrConstraint -> Type
+-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
+--   See Note [Error and friends have an "open-tyvar" forall]
+mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $
+                        mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)
+  where
+    (tyvar:_) = mkTemplateTyVars [kind]
+    kind = case torc of
+              TypeLike       -> mkTYPEapp       runtimeRep1Ty
+              ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -1810,7 +1810,7 @@ tagToEnumRule = do
    -- See Note [tagToEnum#]
    _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
-         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
+         return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type"
 ------------------------------
 dataToTagRule :: RuleM CoreExpr

--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -3528,7 +3528,7 @@ missingAlt env case_bndr _ cont
    -- See Note [Avoiding space leaks in OutType]
    let cont_ty = contResultType cont
    in seqType cont_ty `seq`
-       return (emptyFloats env, mkImpossibleExpr cont_ty)
+       return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt")
 {-
 ************************************************************************

--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1500,7 +1500,7 @@ scExpr' env (Case scrut b ty alts)
  where
    sc_con_app con args scrut'  -- Known constructor; simplify
     = do { let Alt _ bs rhs = findAlt con alts
-                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty)
+                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr")
                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
          ; scExpr alt_env' rhs }

--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -3271,9 +3271,8 @@ mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type
 -- ^ Just like mkTYPEapp_maybe
 {-# NOINLINE mkCONSTRAINTapp_maybe #-}
 mkCONSTRAINTapp_maybe (TyConApp tc args)
-  | key == liftedRepTyConKey = assert (null args) $ Just constraintKind   -- CONSTRAINT LiftedRep
+  | tc `hasKey` liftedRepTyConKey = assert (null args) $
-  where
+                                    Just constraintKind   -- CONSTRAINT LiftedRep
-    key = tyConUnique tc
 mkCONSTRAINTapp_maybe _ = Nothing
 ------------------

--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -1054,20 +1054,11 @@ unify_ty env ty1 ty2 _kco
            ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]
              don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }
-  | Just (tc1, _) <- mb_tc_app1
+  | isTyFamApp mb_tc_app1     -- A (not-over-saturated) type-family application
-  , not (isGenerativeTyCon tc1 Nominal)
+  = maybeApart MARTypeFamily  -- behaves like a type variable; might match
-    -- E.g.   unify_ty (F ty1) b  =  MaybeApart
-    --        because the (F ty1) behaves like a variable
-    --        NB: if unifying, we have already dealt
-    --            with the 'ty2 = variable' case
-  = maybeApart MARTypeFamily
-  | Just (tc2, _) <- mb_tc_app2
+  | isTyFamApp mb_tc_app2     -- A (not-over-saturated) type-family application
-  , not (isGenerativeTyCon tc2 Nominal)
+  , um_unif env               -- behaves like a type variable; might unify
-  , um_unif env
-    -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)
-    --        because the (F ty2) behaves like a variable
-    --        NB: we have already dealt with the 'ty1 = variable' case
  = maybeApart MARTypeFamily
  -- TYPE and CONSTRAINT are not Apart
@@ -1169,6 +1160,17 @@ unify_tys env orig_xs orig_ys
      -- Possibly different saturations of a polykinded tycon
      -- See Note [Polykinded tycon applications]
+isTyFamApp :: Maybe (TyCon, [Type]) -> Bool
+-- True if we have a saturated or under-saturated type family application
+-- If it is /over/ saturated then we return False.  E.g.
+--     unify_ty (F a b) (c d)    where F has arity 1
+-- we definitely want to decompose that type application! (#22647)
+isTyFamApp (Just (tc, tys))
+  =  not (isGenerativeTyCon tc Nominal)       -- Type family-ish
+  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated
+isTyFamApp Nothing
+  = False
 ---------------------------------
 uVar :: UMEnv
     -> InTyVar         -- Variable to be unified

--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -868,8 +868,7 @@ cpeRhsE env (Case scrut bndr ty alts)
               , not (altsAreExhaustive alts)
               = addDefault alts (Just err)
               | otherwise = alts
-               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
+               where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"
-                                             "Bottoming expression returned"
       ; alts'' <- mapM (sat_alt env') alts'
       ; return (floats, Case scrut' bndr2 ty alts'') }

--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -607,7 +607,7 @@ compileForeign hsc_env lang stub_c = do
              LangObjc   -> viaCPipeline Cobjc
              LangObjcxx -> viaCPipeline Cobjcxx
              LangAsm    -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp
-              LangJs     -> \pe hsc_env ml fp -> Just <$> jsPipeline pe hsc_env ml fp
+              LangJs     -> \pe hsc_env ml fp -> Just <$> foreignJsPipeline pe hsc_env ml fp
 #if __GLASGOW_HASKELL__ < 811
              RawObject  -> panic "compileForeign: should be unreachable"
 #endif
@@ -639,7 +639,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
      let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
      writeFile empty_stub (showSDoc dflags (pprCode src))
      let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
-          pipeline = Just <$> jsPipeline pipe_env hsc_env (Just location) empty_stub
+          pipeline = Just <$> foreignJsPipeline pipe_env hsc_env (Just location) empty_stub
      _ <- runPipeline (hsc_hooks hsc_env) pipeline
      pure ()
@@ -858,6 +858,10 @@ jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m Fil
 jsPipeline pipe_env hsc_env location input_fn = do
  use (T_Js pipe_env hsc_env location input_fn)
+foreignJsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
+foreignJsPipeline pipe_env hsc_env location input_fn = do
+  use (T_ForeignJs pipe_env hsc_env location input_fn)
 hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing
 hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing
@@ -928,7 +932,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
   fromPhase StopLn     = return (Just input_fn)
   fromPhase CmmCpp     = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
   fromPhase Cmm        = Just <$> cmmPipeline pipe_env hsc_env input_fn
-   fromPhase Js         = Just <$> jsPipeline pipe_env hsc_env Nothing input_fn
+   fromPhase Js         = Just <$> foreignJsPipeline pipe_env hsc_env Nothing input_fn
   fromPhase MergeForeign = panic "fromPhase: MergeForeign"
 {-

--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -127,7 +127,10 @@ runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
          })
        input_fn output_fn
  return output_fn
-runPhase (T_Js pipe_env hsc_env _mb_location js_src) = runJsPhase pipe_env hsc_env js_src
+runPhase (T_Js pipe_env hsc_env location js_src) =
+  runJsPhase pipe_env hsc_env location js_src
+runPhase (T_ForeignJs pipe_env hsc_env location js_src) =
+  runForeignJsPhase pipe_env hsc_env location js_src
 runPhase (T_Cmm pipe_env hsc_env input_fn) = do
  let dflags = hsc_dflags hsc_env
  let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)
@@ -374,31 +377,27 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do
 -- to ensure these timestamps abide by the proper ordering.
 -- | Run the JS Backend postHsc phase.
-runJsPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
+runJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
-runJsPhase pipe_env hsc_env input_fn = do
+runJsPhase _pipe_env hsc_env _location input_fn = do
+  let dflags     = hsc_dflags   hsc_env
+  let logger     = hsc_logger   hsc_env
+  -- The object file is already generated. We only touch it to ensure the
+  -- timestamp is refreshed, see Note [JS Backend .o file procedure].
+  touchObjectFile logger dflags input_fn
+  return input_fn
+-- | Deal with foreign JS files (embed them into .o files)
+runForeignJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
+runForeignJsPhase pipe_env hsc_env _location input_fn = do
  let dflags     = hsc_dflags   hsc_env
  let logger     = hsc_logger   hsc_env
  let tmpfs      = hsc_tmpfs    hsc_env
  let unit_env   = hsc_unit_env hsc_env
  output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing
+  embedJsFile logger dflags tmpfs unit_env input_fn output_fn
-  -- if the input filename is the same as the output, then we've probably
-  -- generated the object ourselves. In this case, we touch the object file to
-  -- ensure the timestamp is refreshed, see Note [JS Backend .o file procedure]. If
-  -- they are not the same then we embed the .js file into a .o file with the
-  -- addition of a header
-  --
-  -- We need to canonicalize the paths, otherwise the comparison can return
-  -- wrong results (e.g. with Cabal using paths containing "build/./Foo/..."
-  -- that are compared to "build/Foo/...").
-  --
-  cin  <- canonicalizePath input_fn
-  cout <- canonicalizePath output_fn
-  if (not (equalFilePath cin cout))
-    then embedJsFile logger dflags tmpfs unit_env input_fn output_fn
-    else touchObjectFile logger dflags output_fn
  return output_fn

--- a/compiler/GHC/Driver/Pipeline/Phases.hs
+++ b/compiler/GHC/Driver/Pipeline/Phases.hs
@@ -45,6 +45,7 @@ data TPhase res where
  T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
  T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
  T_Js :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
+  T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
  T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
  T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
  T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath

--- a/compiler/GHC/Hs.hs
+++ b/compiler/GHC/Hs.hs
@@ -101,7 +101,8 @@ deriving instance Data (HsModule GhcPs)
 data AnnsModule
  = AnnsModule {
    am_main :: [AddEpAnn],
-    am_decls :: AnnList
+    am_decls :: AnnList,
+    am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- End of file and end of prior token
    } deriving (Data, Eq)
 instance Outputable (HsModule GhcPs) where

--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -65,7 +65,7 @@ import GHC.Core.Map.Expr
 import GHC.Core.Predicate (typeDeterminesValue)
 import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)
 import GHC.Core.Utils     (exprType)
-import GHC.Core.Make      (mkListExpr, mkCharExpr, mkRuntimeErrorApp, rUNTIME_ERROR_ID)
+import GHC.Core.Make      (mkListExpr, mkCharExpr, mkImpossibleExpr)
 import GHC.Data.FastString
 import GHC.Types.SrcLoc
@@ -972,7 +972,7 @@ makeDictsCoherent :: CoreExpr -> CoreExpr
 makeDictsCoherent var@(Var v)
  | let ty = idType v
  , typeDeterminesValue ty
-  = mkRuntimeErrorApp rUNTIME_ERROR_ID ty "dictionary"
+  = mkImpossibleExpr ty "Solver.makeDictsCoherent"
  | otherwise
  = var
 makeDictsCoherent lit@(Lit {})

--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -99,6 +99,7 @@ import Data.Function
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Class
 import Data.Foldable ( toList )
+import GHC.Types.Name.Reader (RdrName(..))
 data MetaWrappers = MetaWrappers {
      -- Applies its argument to a type argument `m` and dictionary `Quote m`
@@ -1647,9 +1648,8 @@ repE (HsUntypedSplice (HsUntypedSpliceNested n) _)  = rep_splice n
 repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e)
 repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
 repE (HsUnboundVar _ uv)   = do
-                               occ   <- occNameLit uv
+                               name <- repRdrName uv
-                               sname <- repNameS occ
+                               repUnboundVar name
-                               repUnboundVar sname
 repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
  e1 <- repLE e
  repGetField e1 f
@@ -2191,31 +2191,40 @@ lookupOccDsM n
                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
    }
-globalVar :: Name -> DsM (Core TH.Name)
 -- Not bound by the meta-env
 -- Could be top-level; or could be local
 --      f x = $(g [| x |])
 -- Here the x will be local
-globalVar name
+globalVar :: Name -> DsM (Core TH.Name)
-  | isExternalName name
+globalVar n =
-  = do  { MkC mod <- coreStringLit name_mod
+  case nameModule_maybe n of
-        ; MkC pkg <- coreStringLit name_pkg
+    Just m -> globalVarExternal m (getOccName n)
-        ; MkC occ <- nameLit name
+    Nothing -> globalVarLocal (getUnique n) (getOccName n)
-        ; rep2_nwDsM mk_varg [pkg,mod,occ] }
-  | otherwise
+globalVarLocal :: Unique -> OccName -> DsM (Core TH.Name)
-  = do  { MkC occ <- nameLit name
+globalVarLocal unique name
+  = do  { MkC occ <- occNameLit name
        ; platform <- targetPlatform <$> getDynFlags
-        ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name))
+        ; let uni = mkIntegerExpr platform (toInteger $ getKey unique)
        ; rep2_nwDsM mkNameLName [occ,uni] }
+globalVarExternal :: Module -> OccName -> DsM (Core TH.Name)
+globalVarExternal mod name_occ
+  = do  {
+        ; MkC mod <- coreStringLit name_mod
+        ; MkC pkg <- coreStringLit name_pkg
+        ; MkC occ <- occNameLit name_occ
+        ; rep2_nwDsM mk_varg [pkg,mod,occ] }
  where
-      mod = assert (isExternalName name) nameModule name
+    name_mod = moduleNameFS (moduleName mod)
-      name_mod = moduleNameFS (moduleName mod)
+    name_pkg = unitFS (moduleUnit mod)
-      name_pkg = unitFS (moduleUnit mod)
+    mk_varg | isDataOcc name_occ = mkNameG_dName
-      name_occ = nameOccName name
+            | isVarOcc  name_occ = mkNameG_vName
-      mk_varg | isDataOcc name_occ = mkNameG_dName
+            | isTcOcc   name_occ = mkNameG_tcName
-              | isVarOcc  name_occ = mkNameG_vName
+            | otherwise          = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ)
-              | isTcOcc   name_occ = mkNameG_tcName
-              | otherwise          = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)
 lookupType :: Name      -- Name of type constructor (e.g. (M TH.Exp))
           -> MetaM Type  -- The type
@@ -2243,15 +2252,12 @@ wrapGenSyms binds body@(MkC b)
    go _ [] = return body
    go var_ty ((name,id) : binds)
      = do { MkC body'  <- go var_ty binds
-           ; lit_str    <- lift $ nameLit name
+           ; lit_str    <- occNameLit (occName name)
           ; gensym_app <- repGensym lit_str
           ; repBindM var_ty elt_ty
                      gensym_app (MkC (Lam id body')) }
-nameLit :: Name -> DsM (Core String)
+occNameLit :: MonadThings m => OccName -> m (Core String)
-nameLit n = coreStringLit (occNameFS (nameOccName n))
-occNameLit :: OccName -> MetaM (Core String)
 occNameLit name = coreStringLit (occNameFS name)
@@ -2945,9 +2951,25 @@ mk_lit (HsIntegral i)     = mk_integer  (il_value i)
 mk_lit (HsFractional f)   = mk_rational f
 mk_lit (HsIsString _ s)   = mk_string   s
+repRdrName :: RdrName -> MetaM (Core TH.Name)
+repRdrName rdr_name = do
+  case rdr_name of
+    Unqual occ ->
+      repNameS =<< occNameLit occ
+    Qual mn occ -> do
+      let name_mod = moduleNameFS mn
+      mod <- coreStringLit name_mod
+      occ <- occNameLit occ
+      repNameQ mod occ
+    Orig m n -> lift $ globalVarExternal m n
+    Exact n -> lift $ globalVar n
 repNameS :: Core String -> MetaM (Core TH.Name)
 repNameS (MkC name) = rep2_nw mkNameSName [name]
+repNameQ :: Core String -> Core String -> MetaM (Core TH.Name)
+repNameQ (MkC mn) (MkC name) = rep2_nw mkNameQName [mn, name]
 --------------- Miscellaneous -------------------
 repGensym :: Core String -> MetaM (Core (M TH.Name))

--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -886,7 +886,7 @@ signature :: { Located (HsModule GhcPs) }
       : 'signature' modid maybemodwarning maybeexports 'where' body
             {% fileSrcSpan >>= \ loc ->
                acs (\cs-> (L loc (HsModule (XModulePs
-                                               (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+                                               (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) Nothing) cs)
                                               (thdOf3 $6) $3 Nothing)
                                            (Just $2) $4 (fst $ sndOf3 $6)
                                            (snd $ sndOf3 $6)))
@@ -895,16 +895,16 @@ signature :: { Located (HsModule GhcPs) }
 module :: { Located (HsModule GhcPs) }
       : 'module' modid maybemodwarning maybeexports 'where' body
             {% fileSrcSpan >>= \ loc ->
-                acsFinal (\cs -> (L loc (HsModule (XModulePs
+                acsFinal (\cs eof -> (L loc (HsModule (XModulePs
-                                                     (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+                                                     (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6) eof) cs)
                                                     (thdOf3 $6) $3 Nothing)
                                                  (Just $2) $4 (fst $ sndOf3 $6)
                                                  (snd $ sndOf3 $6))
                    )) }
        | body2
                {% fileSrcSpan >>= \ loc ->
-                   acsFinal (\cs -> (L loc (HsModule (XModulePs
+                   acsFinal (\cs eof -> (L loc (HsModule (XModulePs
-                                                        (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)
+                                                        (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1) eof) cs)
                                                        (thdOf3 $1) Nothing Nothing)
                                                     Nothing Nothing
                                                     (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) }
@@ -956,14 +956,14 @@ header  :: { Located (HsModule GhcPs) }
        : 'module' modid maybemodwarning maybeexports 'where' header_body
                {% fileSrcSpan >>= \ loc ->
                   acs (\cs -> (L loc (HsModule (XModulePs
-                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)
+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] []) Nothing) cs)
                                                   NoLayoutInfo $3 Nothing)
                                                (Just $2) $4 $6 []
                          ))) }
        | 'signature' modid maybemodwarning maybeexports 'where' header_body
                {% fileSrcSpan >>= \ loc ->
                   acs (\cs -> (L loc (HsModule (XModulePs
-                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)
+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] []) Nothing) cs)
                                                   NoLayoutInfo $3 Nothing)
                                                (Just $2) $4 $6 []
                          ))) }
@@ -4277,17 +4277,17 @@ acs a = do
  return (a cs)
 -- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.
-acsFinal :: (EpAnnComments -> Located a) -> P (Located a)
+acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)
 acsFinal a = do
-  let (L l _) = a emptyComments
+  let (L l _) = a emptyComments Nothing
  cs <- getCommentsFor l
  csf <- getFinalCommentsFor l
  meof <- getEofPos
  let ce = case meof of
-             Strict.Nothing  -> EpaComments []
+             Strict.Nothing  -> Nothing
-             Strict.Just (pos `Strict.And` gap) ->
+             Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)
-               EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]
+  return (a (cs Semi.<> csf) ce)
-  return (a (cs Semi.<> csf Semi.<> ce))
 acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)
 acsa a = do

--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -916,18 +916,11 @@ instance Outputable Token where
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When using the Api Annotations to exact print a modified AST, managing
 the space before a comment is important.  The PsSpan in the comment
-token allows this to happen.
+token allows this to happen, and this location is tracked in prev_loc
+in PState.  This only tracks physical tokens, so is not updated for
-We also need to track the space before the end of file. The normal
+zero-width ones.
-mechanism of using the previous token does not work, as the ITeof is
-synthesised to come at the same location of the last token, and the
+We also use this to track the space before the end-of-file marker.
-normal previous token updating has by then updated the required
-location.
-We track this using a 2-back location, prev_loc2. This adds extra
-processing to every single token, which is a performance hit for
-something needed only at the end of the file. This needs
-improving. Perhaps a backward scan on eof?
 -}
 {- Note [Minus tokens]
@@ -1363,7 +1356,7 @@ lineCommentToken :: Action
 lineCommentToken span buf len buf2 = do
  b <- getBit RawTokenStreamBit
  if b then do
-         lt <- getLastLocComment
+         lt <- getLastLocIncludingComments
         strtoken (\s -> ITlineComment s lt) span buf len buf2
       else lexToken
@@ -1374,7 +1367,7 @@ lineCommentToken span buf len buf2 = do
 -}
 nested_comment :: Action
 nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do
-  l <- getLastLocComment
+  l <- getLastLocIncludingComments
  let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span
  input <- getInput
  -- Include decorator in comment
@@ -1478,7 +1471,7 @@ withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (Hdk
                 -> P (PsLocated Token)
 withLexedDocType lexDocComment = do
  input@(AI _ buf) <- getInput
-  l <- getLastLocComment
+  l <- getLastLocIncludingComments
  case prevChar buf ' ' of
    -- The `Bool` argument to lexDocComment signals whether or not the next
    -- line of input might also belong to this doc comment.
@@ -2001,7 +1994,7 @@ lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action
 lex_string_prag_comment mkTok span _buf _len _buf2
    = do input <- getInput
         start <- getParsedLoc
-         l <- getLastLocComment
+         l <- getLastLocIncludingComments
         tok <- go l [] input
         end <- getParsedLoc
         return (L (mkPsSpan start end) tok)
@@ -2494,9 +2487,7 @@ data PState = PState {
        tab_first  :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file
        tab_count  :: !Word,             -- number of tab warnings in the file
        last_tk    :: Strict.Maybe (PsLocated Token), -- last non-comment token
-        prev_loc   :: PsSpan,      -- pos of previous token, including comments,
+        prev_loc   :: PsSpan,      -- pos of previous non-virtual token, including comments,
-        prev_loc2  :: PsSpan,      -- pos of two back token, including comments,
-                                   -- see Note [PsSpan in Comments]
        last_loc   :: PsSpan,      -- pos of current token
        last_len   :: !Int,        -- len of current token
        loc        :: PsLoc,       -- current loc (end of prev token + 1)
@@ -2624,24 +2615,21 @@ setLastToken loc len = P $ \s -> POk s {
  } ()
 setLastTk :: PsLocated Token -> P ()
-setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Strict.Just tk
+setLastTk tk@(L l _) = P $ \s ->
-                                       , prev_loc = l
+  if isPointRealSpan (psRealSpan l)
-                                       , prev_loc2 = prev_loc s} ()
+    then POk s { last_tk = Strict.Just tk } ()
+    else POk s { last_tk = Strict.Just tk
+               , prev_loc = l } ()
 setLastComment :: PsLocated Token -> P ()
-setLastComment (L l _) = P $ \s -> POk s { prev_loc = l
+setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } ()
-                                         , prev_loc2 = prev_loc s} ()
 getLastTk :: P (Strict.Maybe (PsLocated Token))
 getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
 -- see Note [PsSpan in Comments]
-getLastLocComment :: P PsSpan
+getLastLocIncludingComments :: P PsSpan
-getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc
+getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc
-- see Note [PsSpan in Comments]
-getLastLocEof :: P PsSpan
-getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2
 getLastLoc :: P PsSpan
 getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc
@@ -3024,7 +3012,6 @@ initParserState options buf loc =
      tab_count     = 0,
      last_tk       = Strict.Nothing,
      prev_loc      = mkPsSpan init_loc init_loc,
-      prev_loc2     = mkPsSpan init_loc init_loc,
      last_loc      = mkPsSpan init_loc init_loc,
      last_len      = 0,
      loc           = init_loc,
@@ -3498,8 +3485,8 @@ lexToken = do
  case alexScanUser exts inp sc of
    AlexEOF -> do
        let span = mkPsSpan loc1 loc1
-        lt <- getLastLocEof
+        lc <- getLastLocIncludingComments
-        setEofPos (psRealSpan span) (psRealSpan lt)
+        setEofPos (psRealSpan span) (psRealSpan lc)
        setLastToken span 0
        return (L span ITeof)
    AlexError (AI loc2 buf) ->

--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1815,7 +1815,7 @@ instance DisambECP (HsExpr GhcPs) where
  rejectPragmaPV _                        = return ()
 hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs
-hsHoleExpr anns = HsUnboundVar anns (mkVarOccFS (fsLit "_"))
+hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_")))
 type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns
 type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL

--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -248,8 +248,9 @@ finishHsVar (L l name)
 rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
 rnUnboundVar v = do
  deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables
+  -- See Note [Reporting unbound names] for difference between qualified and unqualified names.
  unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())
-  return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)
+  return (HsUnboundVar noExtField v, emptyFVs)
 rnExpr (HsVar _ (L l v))
  = do { dflags <- getDynFlags
@@ -751,6 +752,23 @@ bindNonRec will automatically do the right thing, giving us:
    case expr of y -> (\x -> op y x)
 See #18151.
+Note [Reporting unbound names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a name is unqualified and unbound then we unconditionally treat it as a hole
+and carry on compilation for as long as possible.
+If a name is qualified, and out of scope, then by default an error will be raised
+because the user was already more precise. They specified a specific qualification
+and either
+  * The qualification didn't exist, so that precision was wrong.
+  * Or the qualification existed and the thing we were looking for wasn't where
+    the qualification said it would be.
+However we can still defer this error completely, and we do defer it if
+`-fdefer-out-of-scope-variables` is enabled.
 -}
 {-
No results found