.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

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]
-absentErrorIdKey              = mkPreludeMiscIdUnique  1
-augmentIdKey                  = mkPreludeMiscIdUnique  2
-appendIdKey                   = mkPreludeMiscIdUnique  3
-buildIdKey                    = mkPreludeMiscIdUnique  4
-absentConstraintErrorIdKey    = mkPreludeMiscIdUnique  5
-foldrIdKey                    = mkPreludeMiscIdUnique  6
-recSelErrorIdKey              = mkPreludeMiscIdUnique  7
-seqIdKey                      = mkPreludeMiscIdUnique  8
-absentSumFieldErrorIdKey      = mkPreludeMiscIdUnique  9
-eqStringIdKey                 = mkPreludeMiscIdUnique 10
-noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 11
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
-runtimeErrorIdKey             = mkPreludeMiscIdUnique 13
-patErrorIdKey                 = mkPreludeMiscIdUnique 14
-realWorldPrimIdKey            = mkPreludeMiscIdUnique 15
-recConErrorIdKey              = mkPreludeMiscIdUnique 16
-
-unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 17
-unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 18
-unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 19
-
-unpackCStringIdKey            = mkPreludeMiscIdUnique 20
-unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 21
-unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 22
-
-voidPrimIdKey                 = mkPreludeMiscIdUnique 23
-typeErrorIdKey                = mkPreludeMiscIdUnique 24
-divIntIdKey                   = mkPreludeMiscIdUnique 25
-modIntIdKey                   = mkPreludeMiscIdUnique 26
-cstringLengthIdKey            = mkPreludeMiscIdUnique 27
+wildCardKey                    = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
+absentErrorIdKey               = mkPreludeMiscIdUnique  1
+absentConstraintErrorIdKey     = mkPreludeMiscIdUnique  2
+augmentIdKey                   = mkPreludeMiscIdUnique  3
+appendIdKey                    = mkPreludeMiscIdUnique  4
+buildIdKey                     = mkPreludeMiscIdUnique  5
+foldrIdKey                     = mkPreludeMiscIdUnique  6
+recSelErrorIdKey               = mkPreludeMiscIdUnique  7
+seqIdKey                       = mkPreludeMiscIdUnique  8
+absentSumFieldErrorIdKey       = mkPreludeMiscIdUnique  9
+eqStringIdKey                  = mkPreludeMiscIdUnique 10
+noMethodBindingErrorIdKey      = mkPreludeMiscIdUnique 11
+nonExhaustiveGuardsErrorIdKey  = mkPreludeMiscIdUnique 12
+impossibleErrorIdKey           = mkPreludeMiscIdUnique 13
+impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14
+patErrorIdKey                  = mkPreludeMiscIdUnique 15
+realWorldPrimIdKey             = mkPreludeMiscIdUnique 16
+recConErrorIdKey               = mkPreludeMiscIdUnique 17
+
+unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 18
+unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 19
+unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 20
+
+unpackCStringIdKey            = mkPreludeMiscIdUnique 21
+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 22
+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 23
+
+voidPrimIdKey                 = mkPreludeMiscIdUnique 24
+typeErrorIdKey                = mkPreludeMiscIdUnique 25
+divIntIdKey                   = mkPreludeMiscIdUnique 26
+modIntIdKey                   = mkPreludeMiscIdUnique 27
+cstringLengthIdKey            = mkPreludeMiscIdUnique 28
 
 concatIdKey, filterIdKey, zipIdKey,
     bindIOIdKey, returnIOIdKey, newStablePtrIdKey,

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 = ...

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
-recConErrorName, patErrorName :: Name
+recSelErrorName, 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
-rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
-rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
-pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
-nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
-nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
+rEC_SEL_ERROR_ID                = mkRuntimeErrorId TypeLike recSelErrorName
+rEC_CON_ERROR_ID                = mkRuntimeErrorId TypeLike recConErrorName
+pAT_ERROR_ID                    = mkRuntimeErrorId TypeLike patErrorName
+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId TypeLike noMethodBindingErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName
+tYPE_ERROR_ID                   = mkRuntimeErrorId TypeLike 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
+

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

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")
 
 {-
 ************************************************************************

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 }
 

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
-  where
-    key = tyConUnique tc
+  | tc `hasKey` liftedRepTyConKey = assert (null args) $
+                                    Just constraintKind   -- CONSTRAINT LiftedRep
 mkCONSTRAINTapp_maybe _ = Nothing
 
 ------------------

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
-  , not (isGenerativeTyCon tc1 Nominal)
-    -- 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
+  | isTyFamApp mb_tc_app1     -- A (not-over-saturated) type-family application
+  = maybeApart MARTypeFamily  -- behaves like a type variable; might match
 
-  | Just (tc2, _) <- mb_tc_app2
-  , not (isGenerativeTyCon tc2 Nominal)
-  , 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
+  | isTyFamApp mb_tc_app2     -- A (not-over-saturated) type-family application
+  , um_unif env               -- behaves like a type variable; might unify
   = 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

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
-                                             "Bottoming expression returned"
+               where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"
        ; alts'' <- mapM (sat_alt env') alts'
 
        ; return (floats, Case scrut' bndr2 ty alts'') }

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"
 
 {-

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 pipe_env hsc_env input_fn = do
+runJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
+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
-
-  -- 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
-
+  embedJsFile logger dflags tmpfs unit_env input_fn output_fn
   return output_fn
 
 

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

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

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 {})

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
-                               sname <- repNameS occ
-                               repUnboundVar sname
+                               name <- repRdrName uv
+                               repUnboundVar name
 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
-  | isExternalName name
-  = do  { MkC mod <- coreStringLit name_mod
-        ; MkC pkg <- coreStringLit name_pkg
-        ; MkC occ <- nameLit name
-        ; rep2_nwDsM mk_varg [pkg,mod,occ] }
-  | otherwise
-  = do  { MkC occ <- nameLit name
+globalVar :: Name -> DsM (Core TH.Name)
+globalVar n =
+  case nameModule_maybe n of
+    Just m -> globalVarExternal m (getOccName n)
+    Nothing -> globalVarLocal (getUnique n) (getOccName n)
+
+globalVarLocal :: Unique -> OccName -> DsM (Core TH.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_pkg = unitFS (moduleUnit mod)
-      name_occ = nameOccName name
-      mk_varg | isDataOcc name_occ = mkNameG_dName
-              | isVarOcc  name_occ = mkNameG_vName
-              | isTcOcc   name_occ = mkNameG_tcName
-              | otherwise          = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)
+    name_mod = moduleNameFS (moduleName mod)
+    name_pkg = unitFS (moduleUnit mod)
+    mk_varg | isDataOcc name_occ = mkNameG_dName
+            | isVarOcc  name_occ = mkNameG_vName
+            | isTcOcc   name_occ = mkNameG_tcName
+            | otherwise          = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ)
+
 
 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)
-nameLit n = coreStringLit (occNameFS (nameOccName n))
-
-occNameLit :: OccName -> MetaM (Core String)
+occNameLit :: MonadThings m => OccName -> m (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))

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
-                                                     (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)
+                acsFinal (\cs eof -> (L loc (HsModule (XModulePs
+                                                     (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
-                                                        (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)
+                   acsFinal (\cs eof -> (L loc (HsModule (XModulePs
+                                                        (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.Just (pos `Strict.And` gap) ->
-               EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]
-  return (a (cs Semi.<> csf Semi.<> ce))
+             Strict.Nothing  -> Nothing
+             Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)
+  return (a (cs Semi.<> csf) ce)
+
 
 acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)
 acsa a = do

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.
-
-We also need to track the space before the end of file. The normal
-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
-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?
+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
+zero-width ones.
+
+We also use this to track the space before the end-of-file marker.
 -}
 
 {- 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_loc2  :: PsSpan,      -- pos of two back token, including comments,
-                                   -- see Note [PsSpan in Comments]
+        prev_loc   :: PsSpan,      -- pos of previous non-virtual token, including 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
-                                       , prev_loc = l
-                                       , prev_loc2 = prev_loc s} ()
+setLastTk tk@(L l _) = P $ \s ->
+  if isPointRealSpan (psRealSpan l)
+    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
-                                         , prev_loc2 = prev_loc s} ()
+setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } ()
 
 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
-getLastLocComment = 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
+getLastLocIncludingComments :: P PsSpan
+getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc
 
 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
-        setEofPos (psRealSpan span) (psRealSpan lt)
+        lc <- getLastLocIncludingComments
+        setEofPos (psRealSpan span) (psRealSpan lc)
         setLastToken span 0
         return (L span ITeof)
     AlexError (AI loc2 buf) ->

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

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.
+
 -}
 
 {-