diff options
Diffstat (limited to 'compiler/iface/ToIface.hs')
| -rw-r--r-- | compiler/iface/ToIface.hs | 168 |
1 files changed, 109 insertions, 59 deletions
diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs index 6f2acba21d..653b7407da 100644 --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -8,7 +8,7 @@ module ToIface , toIfaceIdBndr , toIfaceBndr , toIfaceForAllBndr - , toIfaceTyVarBinders + , toIfaceTyCoVarBinders , toIfaceTyVar -- * Types , toIfaceType, toIfaceTypeX @@ -22,7 +22,7 @@ module ToIface , tidyToIfaceContext , tidyToIfaceTcArgs -- * Coercions - , toIfaceCoercion + , toIfaceCoercion, toIfaceCoercionX -- * Pattern synonyms , patSynToIfaceDecl -- * Expressions @@ -44,6 +44,8 @@ module ToIface #include "HsVersions.h" +import GhcPrelude + import IfaceSyn import DataCon import Id @@ -72,26 +74,39 @@ import Data.Maybe ( catMaybes ) ---------------- toIfaceTvBndr :: TyVar -> IfaceTvBndr -toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar) - , toIfaceKind (tyVarKind tyvar) - ) +toIfaceTvBndr = toIfaceTvBndrX emptyVarSet -toIfaceIdBndr :: Id -> (IfLclName, IfaceType) -toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) +toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr +toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) + , toIfaceTypeX fr (tyVarKind tyvar) + ) toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] toIfaceTvBndrs = map toIfaceTvBndr +toIfaceIdBndr :: Id -> IfaceIdBndr +toIfaceIdBndr = toIfaceIdBndrX emptyVarSet + +toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr +toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar) + , toIfaceTypeX fr (varType covar) + ) + toIfaceBndr :: Var -> IfaceBndr toIfaceBndr var | isId var = IfaceIdBndr (toIfaceIdBndr var) | otherwise = IfaceTvBndr (toIfaceTvBndr var) -toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis -toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis +toIfaceBndrX :: VarSet -> Var -> IfaceBndr +toIfaceBndrX fr var + | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) + | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) + +toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis +toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis -toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis] -toIfaceTyVarBinders = map toIfaceTyVarBinder +toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] +toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder {- ************************************************************************ @@ -116,9 +131,14 @@ toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType | tv `elemVarSet` fr = IfaceFreeTyVar tv | otherwise = IfaceTyVar (toIfaceTyVar tv) -toIfaceTypeX fr (AppTy t1 t2) = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) +toIfaceTypeX fr ty@(AppTy {}) = + -- Flatten as many argument AppTys as possible, then turn them into an + -- IfaceAppArgs list. + -- See Note [Suppressing invisible arguments] in IfaceType. + let (head, args) = splitAppTys ty + in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args) toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) -toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b) +toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) (toIfaceTypeX (fr `delVarSet` binderVar b) t) toIfaceTypeX fr (FunTy t1 t2) | isPredTy t1 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) @@ -137,15 +157,11 @@ toIfaceTypeX fr (TyConApp tc tys) , n_tys == 2*arity = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) - -- type equalities: see Note [Equality predicates in IfaceType] - | tyConName tc == eqTyConName - = let info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon True) - in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) - | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] - , [k1, k2, _t1, _t2] <- tys - = let homogeneous = k1 `eqType` k2 - info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon homogeneous) + , (k1:k2:_) <- tys + = let info = IfaceTyConInfo IsNotPromoted sort + sort | k1 `eqType` k2 = IfaceEqualityTyCon + | otherwise = IfaceNormalTyCon in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) -- other applications @@ -161,8 +177,11 @@ toIfaceTyVar = occNameFS . getOccName toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName -toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr -toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis +toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet + +toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon @@ -216,15 +235,23 @@ toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion toIfaceCoercionX fr co = go co where - go (Refl r ty) = IfaceReflCo r (toIfaceType ty) - go (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv) + go_mco MRefl = IfaceMRefl + go_mco (MCo co) = IfaceMCo $ go co + + go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) + go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) + go (CoVarCo cv) + -- See [TcTyVars in IfaceType] in IfaceType + | cv `elemVarSet` fr = IfaceFreeCoVar cv + | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) + go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) go (SymCo co) = IfaceSymCo (go co) go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) - go (NthCo d co) = IfaceNthCo d (go co) + go (NthCo _r d co) = IfaceNthCo d (go co) go (LRCo lr co) = IfaceLRCo lr (go co) go (InstCo co arg) = IfaceInstCo (go co) (go arg) - go (CoherenceCo c1 c2) = IfaceCoherenceCo (go c1) (go c2) go (KindCo c) = IfaceKindCo (go c) go (SubCo co) = IfaceSubCo (go co) go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) @@ -236,10 +263,9 @@ toIfaceCoercionX fr co | tc `hasKey` funTyConKey , [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co) | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) - go (FunCo r co1 co2) = IfaceFunCo r (toIfaceCoercion co1) - (toIfaceCoercion co2) + go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2) - go (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv) + go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) (toIfaceCoercionX fr' k) (toIfaceCoercionX fr' co) where @@ -250,13 +276,18 @@ toIfaceCoercionX fr co go_prov (PhantomProv co) = IfacePhantomProv (go co) go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) go_prov (PluginProv str) = IfacePluginProv str - go_prov (HoleProv h) = IfaceHoleProv (chUnique h) -toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet -toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs --- See Note [Suppressing invisible arguments] +toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args + +toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs +toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args + +toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs +-- See Note [Suppressing invisible arguments] in IfaceType -- We produce a result list of args describing visibility -- The awkward case is -- T :: forall k. * -> k @@ -264,34 +295,43 @@ toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs -- T (forall j. blah) * blib -- Is 'blib' visible? It depends on the visibility flag on j, -- so we have to substitute for k. Annoying! -toIfaceTcArgsX fr tc ty_args - = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args +toIfaceAppArgsX fr kind ty_args + = go (mkEmptyTCvSubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) - go _ _ [] = ITC_Nil + go _ _ [] = IA_Nil go env ty ts | Just ty' <- coreView ty = go env ty' ts - go env (ForAllTy (TvBndr tv vis) res) (t:ts) - | isVisibleArgFlag vis = ITC_Vis t' ts' - | otherwise = ITC_Invis t' ts' + go env (ForAllTy (Bndr tv vis) res) (t:ts) + | isVisibleArgFlag vis = IA_Vis t' ts' + | otherwise = IA_Invis t' ts' where t' = toIfaceTypeX fr t - ts' = go (extendTvSubst env tv t) res ts + ts' = go (extendTCvSubst env tv t) res ts go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps - = ITC_Vis (toIfaceTypeX fr t) (go env res ts) - - go env (TyVarTy tv) ts - | Just ki <- lookupTyVar env tv = go env ki ts - go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args ) - ITC_Vis (toIfaceTypeX fr t) (go env kind ts) -- Ill-kinded + = IA_Vis (toIfaceTypeX fr t) (go env res ts) + + go env ty ts@(t1:ts1) + | not (isEmptyTCvSubst env) + = go (zapTCvSubst env) (substTy env ty) ts + -- See Note [Care with kind instantiation] in Type.hs + + | otherwise + = -- There's a kind error in the type we are trying to print + -- e.g. kind = k, ty_args = [Int] + -- This is probably a compiler bug, so we print a trace and + -- carry on as if it were FunTy. Without the test for + -- isEmptyTCvSubst we'd get an infinite loop (Trac #15473) + WARN( True, ppr kind $$ ppr ty_args ) + IA_Vis (toIfaceTypeX fr t1) (go env ty ts1) tidyToIfaceType :: TidyEnv -> Type -> IfaceType tidyToIfaceType env ty = toIfaceType (tidyType env ty) -tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext @@ -323,8 +363,8 @@ patSynToIfaceDecl ps (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps univ_bndrs = patSynUnivTyVarBinders ps ex_bndrs = patSynExTyVarBinders ps - (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs - (env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs + (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs to_if_pr (id, needs_dummy) = (idName id, needs_dummy) {- @@ -436,8 +476,15 @@ toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun -toIfUnfolding _ _ - = Nothing +toIfUnfolding _ (OtherCon {}) = Nothing + -- The binding site of an Id doesn't have OtherCon, except perhaps + -- where we have called zapUnfolding; and that evald'ness info is + -- not needed by importing modules + +toIfUnfolding _ BootUnfolding = Nothing + -- Can't happen; we only have BootUnfolding for imported binders + +toIfUnfolding _ NoUnfolding = Nothing {- ************************************************************************ @@ -515,19 +562,22 @@ toIfaceApp (Var v) as toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr -mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as +mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as --------------------- toIfaceVar :: Id -> IfaceExpr toIfaceVar v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) - -- Foreign calls have special syntax | isBootUnfolding (idUnfolding v) - = IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v)))) + = -- See Note [Inlining and hs-boot files] + IfaceApp (IfaceApp (IfaceExt noinlineIdName) + (IfaceType (toIfaceType (idType v)))) (IfaceExt name) -- don't use mkIfaceApps, or infinite loop - -- See Note [Inlining and hs-boot files] - | isExternalName name = IfaceExt name - | otherwise = IfaceLcl (getOccFS name) + + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) + -- Foreign calls have special syntax + + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (getOccFS name) where name = idName v |