Commit 75355fde authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Marge Bot

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.
parent 3e17a866
Pipeline #13783 failed with stages
in 496 minutes and 14 seconds
...@@ -97,7 +97,7 @@ mkPmId :: Type -> DsM Id ...@@ -97,7 +97,7 @@ mkPmId :: Type -> DsM Id
mkPmId ty = getUniqueM >>= \unique -> mkPmId ty = getUniqueM >>= \unique ->
let occname = mkVarOccFS $ fsLit "pm" let occname = mkVarOccFS $ fsLit "pm"
name = mkInternalName unique occname noSrcSpan name = mkInternalName unique occname noSrcSpan
in return (mkLocalId name ty) in return (mkLocalIdOrCoVar name ty)
----------------------------------------------- -----------------------------------------------
-- * Caching possible matches of a COMPLETE set -- * Caching possible matches of a COMPLETE set
...@@ -508,7 +508,7 @@ nameTyCt (TyCt pred_ty) = do ...@@ -508,7 +508,7 @@ nameTyCt (TyCt pred_ty) = do
unique <- getUniqueM unique <- getUniqueM
let occname = mkVarOccFS (fsLit ("pm_"++show unique)) let occname = mkVarOccFS (fsLit ("pm_"++show unique))
idname = mkInternalName unique occname noSrcSpan 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 -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we
-- find a contradiction (e.g. @Int ~ Bool@). -- find a contradiction (e.g. @Int ~ Bool@).
......
...@@ -35,7 +35,6 @@ module Id ( ...@@ -35,7 +35,6 @@ module Id (
-- ** Simple construction -- ** Simple construction
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar,
mkLocalIdOrCoVarWithInfo,
mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId,
mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM,
mkUserLocal, mkUserLocalOrCoVar, mkUserLocal, mkUserLocalOrCoVar,
...@@ -265,10 +264,9 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId ...@@ -265,10 +264,9 @@ mkVanillaGlobalWithInfo = mkGlobalId VanillaId
-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal"
mkLocalId :: Name -> Type -> Id mkLocalId :: HasDebugCallStack => Name -> Type -> Id
mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo mkLocalId name ty = ASSERT( not (isCoVarType ty) )
-- It's tempting to ASSERT( not (isCoVarType ty) ), but don't. Sometimes, mkLocalIdWithInfo name ty vanillaIdInfo
-- the type is a panic. (Search invented_id)
-- | Make a local CoVar -- | Make a local CoVar
mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar :: Name -> Type -> CoVar
...@@ -282,18 +280,10 @@ mkLocalIdOrCoVar name ty ...@@ -282,18 +280,10 @@ mkLocalIdOrCoVar name ty
| isCoVarType ty = mkLocalCoVar name ty | isCoVarType ty = mkLocalCoVar name ty
| otherwise = mkLocalId 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! -- proper ids only; no covars!
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info mkLocalIdWithInfo name ty info = ASSERT( not (isCoVarType ty) )
Var.mkLocalVar VanillaId name ty info
-- Note [Free type variables] -- Note [Free type variables]
-- | Create a local 'Id' that is marked as exported. -- | Create a local 'Id' that is marked as exported.
...@@ -345,11 +335,13 @@ instantiated before use. ...@@ -345,11 +335,13 @@ instantiated before use.
-- | Workers get local names. "CoreTidy" will externalise these if necessary -- | Workers get local names. "CoreTidy" will externalise these if necessary
mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId uniq unwrkr ty 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 -- | 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 :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty 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 -- | Create a template local for a series of types
mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals :: [Type] -> [Id]
......
...@@ -890,6 +890,8 @@ case of a newtype constructor, we simply hardcode its dcr_bangs field to ...@@ -890,6 +890,8 @@ case of a newtype constructor, we simply hardcode its dcr_bangs field to
newLocal :: Type -> UniqSM Var newLocal :: Type -> UniqSM Var
newLocal ty = do { uniq <- getUniqueM newLocal ty = do { uniq <- getUniqueM
; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }
-- We should not have "OrCoVar" here, this is a bug (#17545)
-- | Unpack/Strictness decisions from source module. -- | Unpack/Strictness decisions from source module.
-- --
......
...@@ -1190,4 +1190,6 @@ freshEtaId n subst ty ...@@ -1190,4 +1190,6 @@ freshEtaId n subst ty
ty' = Type.substTyUnchecked subst ty ty' = Type.substTyUnchecked subst ty
eta_id' = uniqAway (getTCvInScope subst) $ eta_id' = uniqAway (getTCvInScope subst) $
mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty'
-- "OrCoVar" since this can be used to eta-expand
-- coercion abstractions
subst' = extendTCvInScope subst eta_id' subst' = extendTCvInScope subst eta_id'
...@@ -193,6 +193,8 @@ mkWildEvBinder pred = mkWildValBinder pred ...@@ -193,6 +193,8 @@ mkWildEvBinder pred = mkWildValBinder pred
-- See Note [WildCard binders] in SimplEnv -- See Note [WildCard binders] in SimplEnv
mkWildValBinder :: Type -> Id mkWildValBinder :: Type -> Id
mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty 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 mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
-- Make a case expression whose case binder is unused -- Make a case expression whose case binder is unused
......
...@@ -349,8 +349,8 @@ duplicateLocalDs old_local ...@@ -349,8 +349,8 @@ duplicateLocalDs old_local
; return (setIdUnique old_local uniq) } ; return (setIdUnique old_local uniq) }
newPredVarDs :: PredType -> DsM Var newPredVarDs :: PredType -> DsM Var
newPredVarDs pred newPredVarDs
= newSysLocalDs pred = mkSysLocalOrCoVarM (fsLit "ds") -- like newSysLocalDs, but we allow covars
newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDsNoLP = mk_local (fsLit "ds") newSysLocalDsNoLP = mk_local (fsLit "ds")
...@@ -358,8 +358,8 @@ newSysLocalDsNoLP = mk_local (fsLit "ds") ...@@ -358,8 +358,8 @@ newSysLocalDsNoLP = mk_local (fsLit "ds")
-- this variant should be used when the caller can be sure that the variable type -- 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 -- 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] -- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") newSysLocalDs = mkSysLocalM (fsLit "ds")
newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail") newFailLocalDs = mkSysLocalM (fsLit "fail")
-- the fail variable is used only in a situation where we can tell that -- the fail variable is used only in a situation where we can tell that
-- levity-polymorphism is impossible. -- levity-polymorphism is impossible.
......
...@@ -164,14 +164,13 @@ coreExprToBCOs hsc_env this_mod expr ...@@ -164,14 +164,13 @@ coreExprToBCOs hsc_env this_mod expr
-- create a totally bogus name for the top-level BCO; this -- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything -- should be harmless, since it's never used for anything
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") 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 -- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions -- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y' us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
<- runBc hsc_env us this_mod Nothing emptyVarEnv $ <- runBc hsc_env us this_mod Nothing emptyVarEnv $
schemeTopBind (invented_id, simpleFreeVars expr) schemeR [] (invented_name, simpleFreeVars expr)
when (notNull mallocd) when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
...@@ -321,7 +320,7 @@ schemeTopBind (id, rhs) ...@@ -321,7 +320,7 @@ schemeTopBind (id, rhs)
(Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise | otherwise
= schemeR [{- No free variables -}] (id, rhs) = schemeR [{- No free variables -}] (getName id, rhs)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
...@@ -333,13 +332,13 @@ schemeTopBind (id, rhs) ...@@ -333,13 +332,13 @@ schemeTopBind (id, rhs)
-- removing the free variables and arguments. -- removing the free variables and arguments.
-- --
-- Park the resulting BCO in the monad. Also requires the -- Park the resulting BCO in the monad. Also requires the
-- variable to which this value was bound, so as to give the -- name of the variable to which this value was bound,
-- resulting BCO a name. -- so as to give the resulting BCO a name.
schemeR :: [Id] -- Free vars of the RHS, ordered as they schemeR :: [Id] -- Free vars of the RHS, ordered as they
-- will appear in the thunk. Empty for -- will appear in the thunk. Empty for
-- top-level things, which have no free vars. -- top-level things, which have no free vars.
-> (Id, AnnExpr Id DVarSet) -> (Name, AnnExpr Id DVarSet)
-> BcM (ProtoBCO Name) -> BcM (ProtoBCO Name)
schemeR fvs (nm, rhs) schemeR fvs (nm, rhs)
{- {-
...@@ -370,7 +369,7 @@ collect (_, e) = go [] e ...@@ -370,7 +369,7 @@ collect (_, e) = go [] e
schemeR_wrk schemeR_wrk
:: [Id] :: [Id]
-> Id -> Name
-> AnnExpr Id DVarSet -- expression e, for debugging only -> AnnExpr Id DVarSet -- expression e, for debugging only
-> ([Var], AnnExpr' Var DVarSet) -- result of collect on e -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e
-> BcM (ProtoBCO Name) -> BcM (ProtoBCO Name)
...@@ -396,7 +395,7 @@ schemeR_wrk fvs nm original_body (args, body) ...@@ -396,7 +395,7 @@ schemeR_wrk fvs nm original_body (args, body)
bitmap = mkBitmap dflags bits bitmap = mkBitmap dflags bits
body_code <- schemeER_wrk sum_szsb_args p_init body 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-}) arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions -- introduce break instructions for ticked expressions
...@@ -575,7 +574,7 @@ schemeE d s p (AnnLet binds (_,body)) = do ...@@ -575,7 +574,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
_other -> False _other -> False
compile_bind d' fvs x rhs size arity off = do 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 build_thunk d' fvs size bco off arity
compile_binds = compile_binds =
......
...@@ -1321,6 +1321,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do ...@@ -1321,6 +1321,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
let let
scrut_ty = exprType scrut' scrut_ty = exprType scrut'
case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty 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 tc_app = splitTyConApp scrut_ty
-- NB: Won't always succeed (polymorphic case) -- NB: Won't always succeed (polymorphic case)
-- but won't be demanded in those cases -- but won't be demanded in those cases
...@@ -1337,7 +1339,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) ...@@ -1337,7 +1339,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
; ty' <- tcIfaceType ty ; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
NotTopLevel name ty' info NotTopLevel name ty' info
; let id = mkLocalIdOrCoVarWithInfo name ty' id_info ; let id = mkLocalIdWithInfo name ty' id_info
`asJoinId_maybe` tcJoinInfo ji `asJoinId_maybe` tcJoinInfo ji
; rhs' <- tcIfaceExpr rhs ; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
...@@ -1353,7 +1355,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) ...@@ -1353,7 +1355,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
tc_rec_bndr (IfLetBndr fs ty _ ji) tc_rec_bndr (IfLetBndr fs ty _ ji)
= do { name <- newIfaceName (mkVarOccFS fs) = do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty ; 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 tc_pair (IfLetBndr _ _ info _, rhs) id
= do { rhs' <- tcIfaceExpr rhs = do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
...@@ -1733,6 +1735,7 @@ bindIfaceId (fs, ty) thing_inside ...@@ -1733,6 +1735,7 @@ bindIfaceId (fs, ty) thing_inside
= do { name <- newIfaceName (mkVarOccFS fs) = do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty ; ty' <- tcIfaceType ty
; let id = mkLocalIdOrCoVar name ty' ; let id = mkLocalIdOrCoVar name ty'
-- We should not have "OrCoVar" here, this is a bug (#17545)
; extendIfaceIdEnv [id] (thing_inside id) } ; extendIfaceIdEnv [id] (thing_inside id) }
bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
......
...@@ -1658,7 +1658,7 @@ newPolyBndrs dest_lvl ...@@ -1658,7 +1658,7 @@ newPolyBndrs dest_lvl
mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.hs mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.hs
transfer_join_info bndr $ transfer_join_info bndr $
mkSysLocalOrCoVar (mkFastString str) uniq poly_ty mkSysLocal (mkFastString str) uniq poly_ty
where where
str = "poly_" ++ occNameString (getOccName bndr) str = "poly_" ++ occNameString (getOccName bndr)
poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr)) poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))
...@@ -1693,7 +1693,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static ...@@ -1693,7 +1693,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
= mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
rhs_ty rhs_ty
| otherwise | otherwise
= mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty = mkSysLocal (mkFastString "lvl") uniq rhs_ty
-- | Clone the binders bound by a single-alternative case. -- | Clone the binders bound by a single-alternative case.
cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
......
...@@ -1800,7 +1800,7 @@ abstractFloats dflags top_lvl main_tvs floats body ...@@ -1800,7 +1800,7 @@ abstractFloats dflags top_lvl main_tvs floats body
; let poly_name = setNameUnique (idName var) uniq -- Keep same name ; let poly_name = setNameUnique (idName var) uniq -- Keep same name
poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course
poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs 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)) } ; 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, -- 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! -- because we were looking at occurrence-analysed but as yet unsimplified code!
......
...@@ -578,7 +578,7 @@ makeTrivialWithInfo mode top_lvl occ_fs info expr ...@@ -578,7 +578,7 @@ makeTrivialWithInfo mode top_lvl occ_fs info expr
else do else do
{ uniq <- getUniqueM { uniq <- getUniqueM
; let name = mkSystemVarName uniq occ_fs ; let name = mkSystemVarName uniq occ_fs
var = mkLocalIdOrCoVarWithInfo name expr_ty info var = mkLocalIdWithInfo name expr_ty info
-- Now something very like completeBind, -- Now something very like completeBind,
-- but without the postInlineUnconditinoally part -- but without the postInlineUnconditinoally part
......
...@@ -296,7 +296,7 @@ withLiftedBndr abs_ids bndr inner = do ...@@ -296,7 +296,7 @@ withLiftedBndr abs_ids bndr inner = do
-- not be caffy themselves and subsequently will miss a static link -- not be caffy themselves and subsequently will miss a static link
-- field in their closure. Chaos ensues. -- field in their closure. Chaos ensues.
. flip setIdCafInfo caf_info . flip setIdCafInfo caf_info
. mkSysLocalOrCoVar (mkFastString str) uniq . mkSysLocal (mkFastString str) uniq
$ ty $ ty
LiftM $ RWS.local LiftM $ RWS.local
(\e -> e (\e -> e
......
...@@ -730,7 +730,7 @@ mkIds :: FastString -> [UnaryType] -> UniqSM [Id] ...@@ -730,7 +730,7 @@ mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
mkIds fs tys = mapM (mkId fs) tys mkIds fs tys = mapM (mkId fs) tys
mkId :: FastString -> UnaryType -> UniqSM Id mkId :: FastString -> UnaryType -> UniqSM Id
mkId = mkSysLocalOrCoVarM mkId = mkSysLocalM
isMultiValBndr :: Id -> Bool isMultiValBndr :: Id -> Bool
isMultiValBndr id isMultiValBndr id
......
...@@ -1720,8 +1720,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) ...@@ -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) spec_join_arity | isJoinId fn = Just (length spec_lam_args)
| otherwise = Nothing | otherwise = Nothing
spec_id = mkLocalIdOrCoVar spec_name spec_id = mkLocalId spec_name
(mkLamTypes spec_lam_args body_ty) (mkLamTypes spec_lam_args body_ty)
-- See Note [Transfer strictness] -- See Note [Transfer strictness]
`setIdStrictness` spec_str `setIdStrictness` spec_str
`setIdArity` count isId spec_lam_args `setIdArity` count isId spec_lam_args
......
...@@ -2635,7 +2635,7 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr ...@@ -2635,7 +2635,7 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
newDictBndr env b = do { uniq <- getUniqueM newDictBndr env b = do { uniq <- getUniqueM
; let n = idName b ; let n = idName b
ty' = substTy env (idType 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 newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
-- Give the new Id a similar occurrence name to the old one -- Give the new Id a similar occurrence name to the old one
...@@ -2643,7 +2643,7 @@ newSpecIdSM old_id new_ty join_arity_maybe ...@@ -2643,7 +2643,7 @@ newSpecIdSM old_id new_ty join_arity_maybe
= do { uniq <- getUniqueM = do { uniq <- getUniqueM
; let name = idName old_id ; let name = idName old_id
new_occ = mkSpecOcc (nameOccName name) 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 `asJoinId_maybe` join_arity_maybe
; return new_id } ; return new_id }
......
...@@ -919,7 +919,7 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty ...@@ -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 -- do this check; otherwise (#14000) we may report an ambiguity
-- error for a rather bogus type. -- error for a rather bogus type.
; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) } ; return (mkLocalId poly_name inferred_poly_ty) }
chooseInferredQuantifiers :: TcThetaType -- inferred chooseInferredQuantifiers :: TcThetaType -- inferred
......
...@@ -514,7 +514,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts ...@@ -514,7 +514,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
-- typically something like [(Int,Bool,Int)] -- typically something like [(Int,Bool,Int)]
-- We don't know what tuple_ty is yet, so we use a variable -- We don't know what tuple_ty is yet, so we use a variable
; let mk_n_bndr :: Name -> TcId -> TcId ; 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 -- Ensure that every old binder of type `b` is linked up with its
-- new binder which should have type `n b` -- new binder which should have type `n b`
...@@ -693,7 +693,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ...@@ -693,7 +693,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
--------------- Bulding the bindersMap ---------------- --------------- Bulding the bindersMap ----------------
; let mk_n_bndr :: Name -> TcId -> TcId ; 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 -- Ensure that every old binder of type `b` is linked up with its
-- new binder which should have type `n b` -- new binder which should have type `n b`
......
...@@ -211,7 +211,8 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl ...@@ -211,7 +211,8 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl
tcPatBndr _ bndr_name pat_ty tcPatBndr _ bndr_name pat_ty
= do { pat_ty <- expTypeToType pat_ty = do { pat_ty <- expTypeToType pat_ty
; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr 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, -- Whether or not there is a sig is irrelevant,
-- as this is local -- as this is local
......
...@@ -623,12 +623,12 @@ newSysName occ ...@@ -623,12 +623,12 @@ newSysName occ
newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId fs ty newSysLocalId fs ty
= do { u <- newUnique = do { u <- newUnique
; return (mkSysLocalOrCoVar fs u ty) } ; return (mkSysLocal fs u ty) }
newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys newSysLocalIds fs tys
= do { us <- newUniqueSupply = do { us <- newUniqueSupply
; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) } ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
instance MonadUnique (IOEnv (Env gbl lcl)) where instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM = newUnique getUniqueM = newUnique
......
...@@ -198,7 +198,7 @@ tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) ...@@ -198,7 +198,7 @@ tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
-- error for each out-of-scope type variable used -- error for each out-of-scope type variable used
= do { let ctxt = RuleSigCtxt name = do { let ctxt = RuleSigCtxt name
; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty ; (_ , 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 -- See Note [Pattern signature binders] in TcHsType
-- The type variables scope over subsequent bindings; yuk -- The type variables scope over subsequent bindings; yuk
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment