X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=20aaa9fca8db18a489bd37073339a6f92841b1d3;hp=0b4df3336eacd9df55d4f1639c730bc245127650;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=a73d6d950f6599d35f1e0aeb80d30112816a6928 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 0b4df33..20aaa9f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -17,23 +17,27 @@ import LoadIface ( loadInterface, loadWiredInHomeIface, loadDecls, findAndReadIface ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, refineIfaceIdEnv, + tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, newIfaceName, newIfaceNames, ifaceExportNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, - mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) +import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, + buildClass, + mkAbstractTyConRhs, mkOpenDataTyConRhs, + mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, - mkTyVarTys, ThetaType ) + liftedTypeKindTyCon, unliftedTypeKindTyCon, + openTypeKindTyCon, argTypeKindTyCon, + ubxTupleKindTyCon, ThetaType ) import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName ) +import TyCon ( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss ) import HscTypes ( ExternalPackageState(..), TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), HomeModInfo(..), - emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) + emptyModDetails, lookupTypeEnv, lookupType, + typeEnvIds, mkDetailsFamInstCache ) import InstEnv ( Instance(..), mkImportedInstance ) -import Unify ( coreRefineTys ) import CoreSyn -import CoreUtils ( exprType ) +import CoreUtils ( exprType, dataConRepFSInstPat ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) @@ -45,22 +49,27 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConInstArgTys, isVanillaDataCon ) +import DataCon ( DataCon, dataConWorkId ) import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) -import Var ( TyVar, mkTyVar, tyVarKind ) +import Var ( TyVar, mkTyVar ) import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, - wiredInNameTyThing_maybe, nameParent ) + nameOccName, wiredInNameTyThing_maybe ) import NameEnv -import OccName ( OccName, mkVarOccFS, mkTyVarOcc ) +import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, + pprNameSpace, occNameFS ) import FastString ( FastString ) -import Module ( Module, lookupModuleEnv ) -import UniqSupply ( initUs_ ) +import Module ( Module, moduleName ) +import UniqFM ( lookupUFM ) +import UniqSupply ( initUs_, uniqsFromSupply ) import Outputable import ErrUtils ( Message ) import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, equalLength, splitAtList ) +import Util ( zipWithEqual, equalLength ) import DynFlags ( DynFlag(..), isOneShot ) + +import List ( elemIndex) +import Maybe ( catMaybes ) \end{code} This module takes @@ -160,7 +169,8 @@ importDecl name }}} where nd_doc = ptext SLIT("Need decl for") <+> ppr name - not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name)) + not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> + pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) \end{code} @@ -211,10 +221,12 @@ typecheckIface iface ; exports <- ifaceExportNames (mi_exports iface) -- Finished - ; return (ModDetails { md_types = type_env, - md_insts = dfuns, - md_rules = rules, - md_exports = exports }) + ; return $ ModDetails { md_types = type_env + , md_insts = dfuns + , md_fam_insts = mkDetailsFamInstCache type_env + , md_rules = rules + , md_exports = exports + } } \end{code} @@ -246,7 +258,7 @@ tcHiBootIface mod -- And that's fine, because if M's ModInfo is in the HPT, then -- it's been compiled once, and we don't need to check the boot iface then do { hpt <- getHpt - ; case lookupModuleEnv hpt mod of + ; case lookupUFM hpt (moduleName mod) of Just info | mi_boot (hm_iface info) -> return (hm_details info) other -> return emptyModDetails } @@ -257,17 +269,16 @@ tcHiBootIface mod -- so eps_is_boot will record if any of our imports mention us by -- way of hi-boot file { eps <- getEps - ; case lookupModuleEnv (eps_is_boot eps) mod of { + ; case lookupUFM (eps_is_boot eps) (moduleName mod) of { Nothing -> return emptyModDetails ; -- The typical case Just (_, False) -> failWithTc moduleLoop ; -- Someone below us imported us! -- This is a loop with no hi-boot in the way - Just (mod, True) -> -- There's a hi-boot interface below us + Just (_mod, True) -> -- There's a hi-boot interface below us do { read_result <- findAndReadIface - True -- Explicit import? need mod True -- Hi-boot file @@ -348,40 +359,58 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) tcIfaceDecl (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, - ifCtxt = ctxt, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, - ifVrcs = arg_vrcs, ifRec = is_rec, - ifGeneric = want_generic }) + ifRec = is_rec, + ifGeneric = want_generic, + ifFamInst = mb_family }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tycon <- fixM ( \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; famInst <- + case mb_family of + Nothing -> return Nothing + Just (IfaceFamInst { ifFamInstTyCon = fam + , ifFamInstTys = tys + }) -> + do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) + } + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; buildAlgTyCon tc_name tyvars stupid_theta - cons arg_vrcs is_rec want_generic + cons is_rec want_generic gadt_syn famInst }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) + ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_ty <- tcIfaceType rdr_rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs)) + ; rhs_tyki <- tcIfaceType rdr_rhs_ty + ; let rhs = if isOpen then OpenSynTyCon rhs_tyki + else SynonymTyCon rhs_tyki + ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) } -tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, - ifFDs = rdr_fds, ifSigs = rdr_sigs, - ifVrcs = tc_vrcs, ifRec = tc_isrec }) +tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, + ifTyVars = tv_bndrs, ifFDs = rdr_fds, + ifATs = rdr_ats, ifSigs = rdr_sigs, + ifRec = tc_isrec }) +-- ToDo: in hs-boot files we should really treat abstract classes specially, +-- as we do abstract tycons = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { cls_name <- lookupIfaceTop occ_name ; ctxt <- tcIfaceCtxt rdr_ctxt ; sigs <- mappM tc_sig rdr_sigs ; fds <- mappM tc_fd rdr_fds - ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs + ; ats' <- mappM tcIfaceDecl rdr_ats + ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) + ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } where tc_sig (IfaceClassOp occ dm rdr_ty) @@ -398,38 +427,43 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; tvs2' <- mappM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } + -- For each AT argument compute the position of the corresponding class + -- parameter in the class head. This will later serve as a permutation + -- vector when checking the validity of instance declarations. + setTyThingPoss (ATyCon tycon) atTyVars = + let classTyVars = map fst tv_bndrs + poss = catMaybes + . map ((`elemIndex` classTyVars) . fst) + $ atTyVars + -- There will be no Nothing, as we already passed renaming + in + ATyCon (setTyConArgPoss tycon poss) + setTyThingPoss _ _ = panic "TcIface.setTyThingPoss" + tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name - liftedTypeKind 0 [])) } + liftedTypeKind 0)) } -tcIfaceDataCons tycon tc_tyvars if_cons +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs + IfOpenDataTyCon -> return mkOpenDataTyConRhs + IfOpenNewTyCon -> return mkOpenNewTyConRhs IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con - ; return (mkNewTyConRhs tycon data_con) } + ; mkNewTyConRhs tycon_name tycon data_con } where - tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, - ifConStricts = stricts, ifConFields = field_lbls}) - = do { name <- lookupIfaceTop occ - -- Read the argument types, but lazily to avoid faulting in - -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; lbl_names <- mappM lookupIfaceTop field_lbls - ; buildDataCon name is_infix True {- Vanilla -} - stricts lbl_names - tc_tyvars [] arg_tys tycon - (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys - } - - tc_con_decl (IfGadtCon { ifConTyVars = con_tvs, - ifConOcc = occ, ifConCtxt = ctxt, - ifConArgTys = args, ifConResTys = ress, - ifConStricts = stricts}) - = bindIfaceTyVars con_tvs $ \ con_tyvars -> do + tc_con_decl (IfCon { ifConInfix = is_infix, + ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, + ifConArgTys = args, ifConFields = field_lbls, + ifConStricts = stricts}) + = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do + bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { name <- lookupIfaceTop occ + ; eq_spec <- tcIfaceEqSpec spec ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here -- At one stage I thought that this context checking *had* -- to be lazy, because of possible mutual recursion between the @@ -443,14 +477,22 @@ tcIfaceDataCons tycon tc_tyvars if_cons -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress) + ; lbl_names <- mappM lookupIfaceTop field_lbls - ; buildDataCon name False {- Not infix -} False {- Not vanilla -} - stricts [{- No fields -}] - con_tyvars theta - arg_tys tycon res_tys + ; buildDataCon name is_infix {- Not infix -} + stricts lbl_names + univ_tyvars ex_tyvars + eq_spec theta + arg_tys tycon } mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name + +tcIfaceEqSpec spec + = mapM do_item spec + where + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) + ; ty <- tcIfaceType if_ty + ; return (tv,ty) } \end{code} @@ -545,6 +587,7 @@ tcIfaceTypes tys = mapM tcIfaceType tys tcIfacePredType :: IfacePredType -> IfL PredType tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } +tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') } ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType @@ -634,12 +677,14 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) where (bndrs, rhss) = unzip pairs +tcIfaceExpr (IfaceCast expr co) = do + expr' <- tcIfaceExpr expr + co' <- tcIfaceType co + returnM (Cast expr' co') + tcIfaceExpr (IfaceNote note expr) = tcIfaceExpr expr `thenM` \ expr' -> case note of - IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> - returnM (Note (Coerce to_ty' - (exprType expr')) expr') IfaceInlineMe -> returnM (Note InlineMe expr') IfaceSCC cc -> returnM (Note (SCC cc) expr') IfaceCoreNote n -> returnM (Note (CoreNote n) expr') @@ -663,47 +708,24 @@ tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) ; ASSERT2( con `elem` tyConDataCons tycon, ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) + tcIfaceDataAlt con inst_tys arg_strs rhs } - if isVanillaDataCon con then - tcVanillaAlt con inst_tys arg_strs rhs - else - do { -- General case - let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs - ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs - ; id_names <- mapM (newIfaceName . mkVarOccFS) id_strs - ; let tyvars = [ mkTyVar name (tyVarKind tv) - | (name,tv) <- tyvar_names `zip` dataConTyVars con ] - arg_tys = dataConInstArgTys con (mkTyVarTys tyvars) - arg_ids = ASSERT2( equalLength id_names arg_tys, - ppr (con, tyvar_names++id_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) - zipWith mkLocalId id_names arg_tys - - Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys) - - ; rhs' <- extendIfaceTyVarEnv tyvars $ - extendIfaceIdEnv arg_ids $ - refineIfaceIdEnv refine $ - -- You might think that we don't need to refine the envt here, - -- but we do: \(x::a) -> case y of - -- MkT -> case x of { True -> ... } - -- In the "case x" we need to know x's type, because we use that - -- to find which module to look for "True" in. Sigh. - tcIfaceExpr rhs - ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} - tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) = ASSERT( isTupleTyCon tycon ) do { let [data_con] = tyConDataCons tycon - ; tcVanillaAlt data_con inst_tys arg_occs rhs } - -tcVanillaAlt data_con inst_tys arg_strs rhs - = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs) - ; let arg_tys = dataConInstArgTys data_con inst_tys - ; let arg_ids = ASSERT2( equalLength arg_names arg_tys, - ppr data_con <+> ppr inst_tys <+> ppr arg_strs $$ ppr rhs ) - zipWith mkLocalId arg_names arg_tys - ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs) - ; returnM (DataAlt data_con, arg_ids, rhs') } + ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } + +tcIfaceDataAlt con inst_tys arg_strs rhs + = do { us <- newUniqueSupply + ; let uniqs = uniqsFromSupply us + ; let (ex_tvs, co_tvs, arg_ids) + = dataConRepFSInstPat arg_strs uniqs con inst_tys + all_tvs = ex_tvs ++ co_tvs + + ; rhs' <- extendIfaceTyVarEnv all_tvs $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, all_tvs ++ arg_ids, rhs') } \end{code} @@ -843,7 +865,8 @@ tcIfaceGlobal name -- and its RULES are loaded too | otherwise = do { (eps,hpt) <- getEpsAndHpt - ; case lookupType hpt (eps_PTE eps) name of { + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { Just thing -> return thing ; Nothing -> do @@ -884,6 +907,12 @@ tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm #else check_tc tc = tc #endif +-- we should be okay just returning Kind constructors without extra loading +tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon +tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon +tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon +tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon +tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- Even though we are in an interface file, we want to make -- sure the instances and RULES of this tycon are loaded @@ -962,17 +991,20 @@ newExtCoreBndr (var, ty) bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside = do { name <- newIfaceName (mkTyVarOcc occ) - ; let tyvar = mk_iface_tyvar name kind + ; tyvar <- mk_iface_tyvar name kind ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside = do { names <- newIfaceNames (map mkTyVarOcc occs) - ; let tyvars = zipWith mk_iface_tyvar names kinds + ; tyvars <- zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where (occs,kinds) = unzip bndrs -mk_iface_tyvar name kind = mkTyVar name kind +mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar +mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind + ; return (mkTyVar name kind) + } \end{code}