From 8ffdb8eed6b38db00761093889f5cddbe8ca1d60 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 3 Jan 2007 11:50:09 +0000 Subject: [PATCH] Fix several bugs related to finding free variables Now that coercion variables mention types, a type-lambda binder can have free variables. This patch adjusts the free-variable finder to take account of this, by treating Ids and TyVars more uniformly. In addition, I fixed a bug in the specialiser that was missing a free type variable in a binder. And a bug in tyVarsOfInst that was missing the type variables in the kinds of the quantified tyvars. --- compiler/basicTypes/Var.lhs | 30 ++++++++++++------------ compiler/coreSyn/CoreFVs.lhs | 44 ++++++++++++++++++------------------ compiler/simplCore/SetLevels.lhs | 3 +-- compiler/specialise/Specialise.lhs | 8 ++++--- compiler/typecheck/Inst.lhs | 8 ++++--- compiler/typecheck/TcPat.lhs | 2 +- 6 files changed, 50 insertions(+), 45 deletions(-) diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index 566d502..cd21b9d 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -7,7 +7,7 @@ \begin{code} module Var ( Var, - varName, varUnique, + varName, varUnique, varType, setVarName, setVarUnique, -- TyVars @@ -71,7 +71,7 @@ data Var realUnique :: FastInt, -- Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed - tyVarKind :: Kind, + varType :: Kind, isCoercionVar :: Bool } @@ -80,14 +80,14 @@ data Var -- inference, as well varName :: !Name, realUnique :: FastInt, - tyVarKind :: Kind, + varType :: Kind, tcTyVarDetails :: TcTyVarDetails } | GlobalId { -- Used for imported Ids, dict selectors etc -- See Note [GlobalId/LocalId] below varName :: !Name, -- Always an External or WiredIn Name realUnique :: FastInt, - idType :: Type, + varType :: Type, idInfo_ :: IdInfo, gblDetails :: GlobalIdDetails } @@ -95,7 +95,7 @@ data Var -- See Note [GlobalId/LocalId] below varName :: !Name, realUnique :: FastInt, - idType :: Type, + varType :: Type, idInfo_ :: IdInfo, lclDetails :: LocalIdDetails } @@ -181,12 +181,13 @@ setVarName var new_name type TyVar = Var tyVarName = varName +tyVarKind = varType setTyVarUnique = setVarUnique setTyVarName = setVarName setTyVarKind :: TyVar -> Kind -> TyVar -setTyVarKind tv k = tv {tyVarKind = k} +setTyVarKind tv k = tv {varType = k} \end{code} \begin{code} @@ -194,7 +195,7 @@ mkTyVar :: Name -> Kind -> TyVar mkTyVar name kind = ASSERT( not (isCoercionKind kind ) ) TyVar { varName = name , realUnique = getKey# (nameUnique name) - , tyVarKind = kind + , varType = kind , isCoercionVar = False } @@ -203,7 +204,7 @@ mkTcTyVar name kind details = ASSERT( not (isCoercionKind kind) ) TcTyVar { varName = name, realUnique = getKey# (nameUnique name), - tyVarKind = kind, + varType = kind, tcTyVarDetails = details } \end{code} @@ -226,7 +227,7 @@ mkCoVar :: Name -> Kind -> CoVar mkCoVar name kind = ASSERT( isCoercionKind kind ) TyVar { varName = name , realUnique = getKey# (nameUnique name) - , tyVarKind = kind + , varType = kind , isCoercionVar = True } @@ -237,7 +238,7 @@ mkWildCoVar kind = ASSERT( isCoercionKind kind ) TyVar { varName = mkSysTvName wild_uniq FSLIT("co_wild"), realUnique = _ILIT(1), - tyVarKind = kind, + varType = kind, isCoercionVar = True } where wild_uniq = mkBuiltinUnique 1 @@ -259,6 +260,7 @@ type DictId = Id \begin{code} idName = varName idUnique = varUnique +idType = varType setIdUnique :: Id -> Unique -> Id setIdUnique = setVarUnique @@ -267,7 +269,7 @@ setIdName :: Id -> Name -> Id setIdName = setVarName setIdType :: Id -> Type -> Id -setIdType id ty = id {idType = ty} +setIdType id ty = id {varType = ty} setIdExported :: Id -> Id -- Can be called on GlobalIds, such as data cons and class ops, @@ -283,7 +285,7 @@ globaliseId :: GlobalIdDetails -> Id -> Id -- If it's a local, make it global globaliseId details id = GlobalId { varName = varName id, realUnique = realUnique id, - idType = idType id, + varType = varType id, idInfo_ = idInfo id, gblDetails = details } @@ -322,7 +324,7 @@ mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id mkGlobalId details name ty info = GlobalId { varName = name, realUnique = getKey# (nameUnique name), -- Cache the unique - idType = ty, + varType = ty, gblDetails = details, idInfo_ = info } @@ -330,7 +332,7 @@ mk_local_id :: Name -> Type -> LocalIdDetails -> IdInfo -> Id mk_local_id name ty details info = LocalId { varName = name, realUnique = getKey# (nameUnique name), -- Cache the unique - idType = ty, + varType = ty, lclDetails = details, idInfo_ = info } diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index c32ca7c..bda9342 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -13,7 +13,7 @@ module CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars, exprFreeNames, exprsFreeNames, - idRuleVars, idFreeVars, idFreeTyVars, + idRuleVars, idFreeVars, varTypeTyVars, ruleRhsFreeVars, rulesRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, @@ -138,10 +138,10 @@ keep_it fv_cand in_scope var addBndr :: CoreBndr -> FV -> FV addBndr bndr fv fv_cand in_scope - | isId bndr = inside_fvs `unionVarSet` someVars (idFreeTyVars bndr) fv_cand in_scope - | otherwise = inside_fvs - where - inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr) + = someVars (varTypeTyVars bndr) fv_cand in_scope + -- Include type varibles in the binder's type + -- (not just Ids; coercion variables too!) + `unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr) addBndrs :: [CoreBndr] -> FV -> FV addBndrs bndrs fv = foldr addBndr fv bndrs @@ -318,18 +318,18 @@ delBinderFV :: Var -> VarSet -> VarSet -- where -- bottom = bottom -- Never evaluated -delBinderFV b s | isId b = (s `delVarSet` b) `unionFVs` idFreeVars b - | otherwise = s `delVarSet` b +delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b + -- Include coercion variables too! -idFreeVars :: Id -> VarSet -idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id +varTypeTyVars :: Var -> TyVarSet +-- Find the type variables free in the type of the variable +-- Remember, coercion variables can mention type variables... +varTypeTyVars var + | isLocalId var || isCoVar var = tyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars -idFreeTyVars :: Id -> TyVarSet --- Only local Ids conjured up locally, can have free type variables. --- (During type checking top-level Ids can have free tyvars) -idFreeTyVars id = tyVarsOfType (idType id) --- | isLocalId id = tyVarsOfType (idType id) --- | otherwise = emptyVarSet +idFreeVars :: Id -> VarSet +idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id idRuleVars ::Id -> VarSet idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id) @@ -369,7 +369,6 @@ freeVars (App fun arg) arg2 = freeVars arg freeVars (Case scrut bndr ty alts) --- gaw 2004 = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty, AnnCase scrut2 bndr ty alts2) where @@ -384,7 +383,8 @@ freeVars (Case scrut bndr ty alts) rhs2 = freeVars rhs freeVars (Let (NonRec binder rhs) body) - = (freeVarsOf rhs2 `unionFVs` body_fvs, + = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` idRuleVars binder, + -- Remember any rules; cf rhs_fvs above AnnLet (AnnNonRec binder rhs2) body2) where rhs2 = freeVars rhs @@ -392,16 +392,16 @@ freeVars (Let (NonRec binder rhs) body) body_fvs = binder `delBinderFV` freeVarsOf body2 freeVars (Let (Rec binds) body) - = (foldl delVarSet group_fvs binders, - -- The "delBinderFV" part may have added one of the binders - -- via the idSpecVars part, so we must delete it again + = (delBindersFV binders all_fvs, AnnLet (AnnRec (binders `zip` rhss2)) body2) where (binders, rhss) = unzip binds rhss2 = map freeVars rhss - all_fvs = foldr (unionFVs . fst) body_fvs rhss2 - group_fvs = delBindersFV binders all_fvs + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + all_fvs = foldr (unionFVs . idRuleVars) rhs_body_fvs binders + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs body2 = freeVars body body_fvs = freeVarsOf body2 diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 225dea5..5dbaec6 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -771,8 +771,7 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v Just (abs_vars, _) -> abs_vars Nothing -> [v] - add_tyvars v | isId v = v : varSetElems (idFreeTyVars v) - | otherwise = [v] + add_tyvars v = v : varSetElems (varTypeTyVars v) -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index fa9d253..86fd2fa 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -23,7 +23,7 @@ import VarSet import VarEnv import CoreSyn import CoreUtils ( applyTypeToArgs, mkPiTypes ) -import CoreFVs ( exprFreeVars, exprsFreeVars, idRuleVars ) +import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) import CoreTidy ( tidyRules ) import CoreLint ( showPass, endPass ) import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds ) @@ -1072,10 +1072,12 @@ bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs bndrs = map fst prs rhs_fvs = unionVarSets (map pair_fvs prs) -pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idRuleVars bndr +pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr -- Don't forget variables mentioned in the -- rules of the bndr. C.f. OccAnal.addRuleUsage - + -- Also tyvars mentioned in its type; they may not appear in the RHS + -- type T a = Int + -- x :: T a = 3 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds } diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 49fba35..a11efe0 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -161,12 +161,14 @@ ipNamesOfInst other = [] tyVarsOfInst :: Inst -> TcTyVarSet tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred -tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id +tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id -- The id might have free type variables; in the case of -- locally-overloaded class methods, for example tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds}) - = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs - + = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) + `minusVarSet` mkVarSet tvs + `unionVarSet` unionVarSets (map varTypeTyVars tvs) + -- Remember the free tyvars of a coercion tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 5fda4f4..e7fd6ca 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -924,7 +924,7 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env where bound_ids = collectPatsBinders pats show_ids = filter is_interesting bound_ids - is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs + is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs ppr_id id ty = ppr id <+> dcolon <+> ppr ty -- Don't zonk the types so we get the separate, un-unified versions -- 1.7.10.4