Use "OrCoVar" functions less

As described in #17291, we'd like to separate coercions and expressions
in a more robust fashion.
This is a small step in this direction.

- `mkLocalId` now panicks on a covar.
  Calls where this was not the case were changed to `mkLocalIdOrCoVar`.
- Don't use "OrCoVar" functions in places where we know the type is
  not a coercion.

compiler/GHC/HsToCore/PmCheck/Oracle.hs

@@ -97,7 +97,7 @@ mkPmId :: Type -> DsM Id
 mkPmId ty = getUniqueM >>= \unique ->
   let occname = mkVarOccFS $ fsLit "pm"
       name    = mkInternalName unique occname noSrcSpan
-  in  return (mkLocalId name ty)
+  in  return (mkLocalIdOrCoVar name ty)
 
 -----------------------------------------------
 -- * Caching possible matches of a COMPLETE set
@@ -508,7 +508,7 @@ nameTyCt (TyCt pred_ty) = do
   unique <- getUniqueM
   let occname = mkVarOccFS (fsLit ("pm_"++show unique))
       idname  = mkInternalName unique occname noSrcSpan
-  return (mkLocalId idname pred_ty)
+  return (mkLocalIdOrCoVar idname pred_ty)
 
 -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we
 -- find a contradiction (e.g. @Int ~ Bool@).

compiler/basicTypes/Id.hs

@@ -35,7 +35,6 @@ module Id (
         -- ** Simple construction
         mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
         mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,
-        mkLocalIdOrCoVarWithInfo,
         mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,
         mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,
         mkUserLocal, mkUserLocalOrCoVar,
@@ -265,10 +264,9 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId
 
 
 -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"
-mkLocalId :: Name -> Type -> Id
-mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
- -- It's tempting to ASSERT( not (isCoVarType ty) ), but don't. Sometimes,
- -- the type is a panic. (Search invented_id)
+mkLocalId :: HasDebugCallStack => Name -> Type -> Id
+mkLocalId name ty = ASSERT( not (isCoVarType ty) )
+                    mkLocalIdWithInfo name ty vanillaIdInfo
 
 -- | Make a local CoVar
 mkLocalCoVar :: Name -> Type -> CoVar
@@ -282,18 +280,10 @@ mkLocalIdOrCoVar name ty
   | isCoVarType ty = mkLocalCoVar name ty
   | otherwise      = mkLocalId    name ty
 
--- | Make a local id, with the IdDetails set to CoVarId if the type indicates
--- so.
-mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id
-mkLocalIdOrCoVarWithInfo name ty info
-  = Var.mkLocalVar details name ty info
-  where
-    details | isCoVarType ty = CoVarId
-            | otherwise      = VanillaId
-
     -- proper ids only; no covars!
-mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
-mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info
+mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id
+mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) )
+                                 Var.mkLocalVar VanillaId name ty info
         -- Note [Free type variables]
 
 -- | Create a local 'Id' that is marked as exported.
@@ -345,11 +335,13 @@ instantiated before use.
 -- | Workers get local names. "CoreTidy" will externalise these if necessary
 mkWorkerId :: Unique -> Id -> Type -> Id
 mkWorkerId uniq unwrkr ty
-  = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty
+  = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty
 
 -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings
 mkTemplateLocal :: Int -> Type -> Id
 mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty
+   -- "OrCoVar" since this is used in a superclass selector,
+   -- and "~" and "~~" have coercion "superclasses".
 
 -- | Create a template local for a series of types
 mkTemplateLocals :: [Type] -> [Id]

compiler/basicTypes/MkId.hs

@@ -890,6 +890,8 @@ case of a newtype constructor, we simply hardcode its dcr_bangs field to
 newLocal :: Type -> UniqSM Var
 newLocal ty = do { uniq <- getUniqueM
                  ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }
+                 -- We should not have "OrCoVar" here, this is a bug (#17545)
+
 
 -- | Unpack/Strictness decisions from source module.
 --

compiler/coreSyn/CoreArity.hs

@@ -1190,4 +1190,6 @@ freshEtaId n subst ty
         ty'     = Type.substTyUnchecked subst ty
         eta_id' = uniqAway (getTCvInScope subst) $
                   mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty'
+                  -- "OrCoVar" since this can be used to eta-expand
+                  -- coercion abstractions
         subst'  = extendTCvInScope subst eta_id'

compiler/coreSyn/MkCore.hs

@@ -193,6 +193,8 @@ mkWildEvBinder pred = mkWildValBinder pred
 -- See Note [WildCard binders] in SimplEnv
 mkWildValBinder :: Type -> Id
 mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty
+  -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors
+  -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.
 
 mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
 -- Make a case expression whose case binder is unused

compiler/deSugar/DsMonad.hs

@@ -349,17 +349,17 @@ duplicateLocalDs old_local
         ; return (setIdUnique old_local uniq) }
 
 newPredVarDs :: PredType -> DsM Var
-newPredVarDs pred
- = newSysLocalDs pred
+newPredVarDs
+ = mkSysLocalOrCoVarM (fsLit "ds")  -- like newSysLocalDs, but we allow covars
 
 newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 newSysLocalDsNoLP  = mk_local (fsLit "ds")
 
 -- this variant should be used when the caller can be sure that the variable type
 -- is not levity-polymorphic. It is necessary when the type is knot-tied because
 -- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
-newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
-newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
+newSysLocalDs = mkSysLocalM (fsLit "ds")
+newFailLocalDs = mkSysLocalM (fsLit "fail")
   -- the fail variable is used only in a situation where we can tell that
   -- levity-polymorphism is impossible.
 

compiler/ghci/ByteCodeGen.hs

@@ -164,14 +164,13 @@ coreExprToBCOs hsc_env this_mod expr
       -- create a totally bogus name for the top-level BCO; this
       -- should be harmless, since it's never used for anything
       let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
-          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
 
       -- the uniques are needed to generate fresh variables when we introduce new
       -- let bindings for ticked expressions
       us <- mkSplitUniqSupply 'y'
       (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
          <- runBc hsc_env us this_mod Nothing emptyVarEnv $
-              schemeTopBind (invented_id, simpleFreeVars expr)
+              schemeR [] (invented_name, simpleFreeVars expr)
 
       when (notNull mallocd)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
@@ -321,7 +320,7 @@ schemeTopBind (id, rhs)
                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
 
   | otherwise
-  = schemeR [{- No free variables -}] (id, rhs)
+  = schemeR [{- No free variables -}] (getName id, rhs)
 
 
 -- -----------------------------------------------------------------------------
@@ -333,13 +332,13 @@ schemeTopBind (id, rhs)
 -- removing the free variables and arguments.
 --
 -- Park the resulting BCO in the monad.  Also requires the
--- variable to which this value was bound, so as to give the
--- resulting BCO a name.
+-- name of the variable to which this value was bound,
+-- so as to give the resulting BCO a name.
 
 schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
                                 -- will appear in the thunk.  Empty for
                                 -- top-level things, which have no free vars.
-        -> (Id, AnnExpr Id DVarSet)
+        -> (Name, AnnExpr Id DVarSet)
         -> BcM (ProtoBCO Name)
 schemeR fvs (nm, rhs)
 {-
@@ -370,7 +369,7 @@ collect (_, e) = go [] e
 
 schemeR_wrk
     :: [Id]
-    -> Id
+    -> Name
     -> AnnExpr Id DVarSet             -- expression e, for debugging only
     -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e
     -> BcM (ProtoBCO Name)
@@ -396,7 +395,7 @@ schemeR_wrk fvs nm original_body (args, body)
          bitmap = mkBitmap dflags bits
      body_code <- schemeER_wrk sum_szsb_args p_init body
 
-     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
+     emitBc (mkProtoBCO dflags nm body_code (Right original_body)
                  arity bitmap_size bitmap False{-not alts-})
 
 -- introduce break instructions for ticked expressions
@@ -575,7 +574,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
                      _other -> False
 
          compile_bind d' fvs x rhs size arity off = do
-                bco <- schemeR fvs (x,rhs)
+                bco <- schemeR fvs (getName x,rhs)
                 build_thunk d' fvs size bco off arity
 
          compile_binds =

compiler/iface/TcIface.hs

@@ -1321,6 +1321,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
     let
         scrut_ty   = exprType scrut'
         case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
+     -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors
+     -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.
         tc_app     = splitTyConApp scrut_ty
                 -- NB: Won't always succeed (polymorphic case)
                 --     but won't be demanded in those cases
@@ -1337,7 +1339,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
         ; ty'     <- tcIfaceType ty
         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
                               NotTopLevel name ty' info
-        ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
+        ; let id = mkLocalIdWithInfo name ty' id_info
                      `asJoinId_maybe` tcJoinInfo ji
         ; rhs' <- tcIfaceExpr rhs
         ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
@@ -1353,7 +1355,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
    tc_rec_bndr (IfLetBndr fs ty _ ji)
      = do { name <- newIfaceName (mkVarOccFS fs)
           ; ty'  <- tcIfaceType ty
-          ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }
+          ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) }
    tc_pair (IfLetBndr _ _ info _, rhs) id
      = do { rhs' <- tcIfaceExpr rhs
           ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
@@ -1733,6 +1735,7 @@ bindIfaceId (fs, ty) thing_inside
   = do  { name <- newIfaceName (mkVarOccFS fs)
         ; ty' <- tcIfaceType ty
         ; let id = mkLocalIdOrCoVar name ty'
+          -- We should not have "OrCoVar" here, this is a bug (#17545)
         ; extendIfaceIdEnv [id] (thing_inside id) }
 
 bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a

compiler/simplCore/SetLevels.hs

@@ -1658,7 +1658,7 @@ newPolyBndrs dest_lvl
 
     mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $         -- Note [transferPolyIdInfo] in Id.hs
                              transfer_join_info bndr $
-                             mkSysLocalOrCoVar (mkFastString str) uniq poly_ty
+                             mkSysLocal (mkFastString str) uniq poly_ty
                            where
                              str     = "poly_" ++ occNameString (getOccName bndr)
                              poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))
@@ -1693,7 +1693,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
       | otherwise
-      = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty
+      = mkSysLocal (mkFastString "lvl") uniq rhs_ty
 
 -- | Clone the binders bound by a single-alternative case.
 cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])

compiler/simplCore/SimplUtils.hs

@@ -1800,7 +1800,7 @@ abstractFloats dflags top_lvl main_tvs floats body
            ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name
                   poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course
                   poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs
-                              mkLocalIdOrCoVar poly_name poly_ty
+                              mkLocalId poly_name poly_ty
            ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
                 -- In the olden days, it was crucial to copy the occInfo of the original var,
                 -- because we were looking at occurrence-analysed but as yet unsimplified code!

compiler/simplCore/Simplify.hs

@@ -578,7 +578,7 @@ makeTrivialWithInfo mode top_lvl occ_fs info expr
           else do
         { uniq <- getUniqueM
         ; let name = mkSystemVarName uniq occ_fs
-              var  = mkLocalIdOrCoVarWithInfo name expr_ty info
+              var  = mkLocalIdWithInfo name expr_ty info
 
         -- Now something very like completeBind,
         -- but without the postInlineUnconditinoally part

compiler/simplStg/StgLiftLams/LiftM.hs

@@ -296,7 +296,7 @@ withLiftedBndr abs_ids bndr inner = do
         -- not be caffy themselves and subsequently will miss a static link
         -- field in their closure. Chaos ensues.
         . flip setIdCafInfo caf_info
-        . mkSysLocalOrCoVar (mkFastString str) uniq
+        . mkSysLocal (mkFastString str) uniq
         $ ty
   LiftM $ RWS.local
     (\e -> e

compiler/simplStg/UnariseStg.hs

@@ -730,7 +730,7 @@ mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
 mkIds fs tys = mapM (mkId fs) tys
 
 mkId :: FastString -> UnaryType -> UniqSM Id
-mkId = mkSysLocalOrCoVarM
+mkId = mkSysLocalM
 
 isMultiValBndr :: Id -> Bool
 isMultiValBndr id

compiler/specialise/SpecConstr.hs

@@ -1720,8 +1720,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
 
               spec_join_arity | isJoinId fn = Just (length spec_lam_args)
                               | otherwise   = Nothing
-              spec_id    = mkLocalIdOrCoVar spec_name
-                                            (mkLamTypes spec_lam_args body_ty)
+              spec_id    = mkLocalId spec_name
+                                     (mkLamTypes spec_lam_args body_ty)
                              -- See Note [Transfer strictness]
                              `setIdStrictness` spec_str
                              `setIdArity` count isId spec_lam_args

compiler/specialise/Specialise.hs

@@ -2635,15 +2635,15 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
 newDictBndr env b = do { uniq <- getUniqueM
                        ; let n   = idName b
                              ty' = substTy env (idType b)
-                       ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) }
+                       ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }
 
 newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
     -- Give the new Id a similar occurrence name to the old one
 newSpecIdSM old_id new_ty join_arity_maybe
   = do  { uniq <- getUniqueM
         ; let name    = idName old_id
               new_occ = mkSpecOcc (nameOccName name)
-              new_id  = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name)
+              new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
                           `asJoinId_maybe` join_arity_maybe
         ; return new_id }
 

compiler/typecheck/TcBinds.hs

@@ -919,7 +919,7 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
          -- do this check; otherwise (#14000) we may report an ambiguity
          -- error for a rather bogus type.
 
-       ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
+       ; return (mkLocalId poly_name inferred_poly_ty) }
 
 
 chooseInferredQuantifiers :: TcThetaType   -- inferred

compiler/typecheck/TcMatches.hs

@@ -514,7 +514,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
              -- typically something like [(Int,Bool,Int)]
              -- We don't know what tuple_ty is yet, so we use a variable
        ; let mk_n_bndr :: Name -> TcId -> TcId
-             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
+             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
 
              -- Ensure that every old binder of type `b` is linked up with its
              -- new binder which should have type `n b`
@@ -693,7 +693,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
 
        --------------- Bulding the bindersMap ----------------
        ; let mk_n_bndr :: Name -> TcId -> TcId
-             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
+             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
 
              -- Ensure that every old binder of type `b` is linked up with its
              -- new binder which should have type `n b`

compiler/typecheck/TcPat.hs

@@ -211,7 +211,8 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl
 tcPatBndr _ bndr_name pat_ty
   = do { pat_ty <- expTypeToType pat_ty
        ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)
-       ; return (idHsWrapper, mkLocalId bndr_name pat_ty) }
+       ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_ty) }
+               -- We should not have "OrCoVar" here, this is a bug (#17545)
                -- Whether or not there is a sig is irrelevant,
                -- as this is local
 

compiler/typecheck/TcRnMonad.hs

@@ -623,12 +623,12 @@ newSysName occ
 newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
 newSysLocalId fs ty
   = do  { u <- newUnique
-        ; return (mkSysLocalOrCoVar fs u ty) }
+        ; return (mkSysLocal fs u ty) }
 
 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
 newSysLocalIds fs tys
   = do  { us <- newUniqueSupply
-        ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
+        ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
 
 instance MonadUnique (IOEnv (Env gbl lcl)) where
         getUniqueM = newUnique

compiler/typecheck/TcRules.hs

@@ -198,7 +198,7 @@ tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
 --   error for each out-of-scope type variable used
   = do  { let ctxt = RuleSigCtxt name
         ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty
-        ; let id  = mkLocalIdOrCoVar name id_ty
+        ; let id  = mkLocalId name id_ty
                     -- See Note [Pattern signature binders] in TcHsType
 
               -- The type variables scope over subsequent bindings; yuk