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
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@).
......
......@@ -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]
......
......@@ -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.
--
......
......@@ -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'
......@@ -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
......
......@@ -349,8 +349,8 @@ 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")
......@@ -358,8 +358,8 @@ 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.
......
......@@ -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 =
......
......@@ -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
......
......@@ -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])
......
......@@ -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!
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -1720,7 +1720,7 @@ 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
spec_id = mkLocalId spec_name
(mkLamTypes spec_lam_args body_ty)
-- See Note [Transfer strictness]
`setIdStrictness` spec_str
......
......@@ -2635,7 +2635,7 @@ 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
......@@ -2643,7 +2643,7 @@ 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 }
......
......@@ -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
......
......@@ -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`
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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