X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=20aaa9fca8db18a489bd37073339a6f92841b1d3;hp=7c4c5354c6252b36975257d524b51c32a821d63d;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=f2dcf256399e9a2de6343c625630b51f8abf4863 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7c4c535..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,21 +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 ) -import Module ( Module, lookupModuleEnv ) -import UniqSupply ( initUs_ ) +import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, + pprNameSpace, occNameFS ) +import FastString ( FastString ) +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, dropList, equalLength ) +import Util ( zipWithEqual, equalLength ) import DynFlags ( DynFlag(..), isOneShot ) + +import List ( elemIndex) +import Maybe ( catMaybes ) \end{code} This module takes @@ -159,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} @@ -210,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} @@ -245,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 } @@ -256,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 @@ -347,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) @@ -397,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 @@ -442,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} @@ -544,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 @@ -603,7 +647,7 @@ tcIfaceExpr (IfaceApp fun arg) tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = tcIfaceExpr scrut `thenM` \ scrut' -> - newIfaceName case_bndr `thenM` \ case_bndr_name -> + newIfaceName (mkVarOccFS case_bndr) `thenM` \ case_bndr_name -> let scrut_ty = exprType scrut' case_bndr' = mkLocalId case_bndr_name scrut_ty @@ -633,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') @@ -657,51 +703,29 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! -tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs) +tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { let tycon_mod = nameModule (tyConName tycon) ; 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_occs rhs - else - do { -- General case - arg_names <- newIfaceNames arg_occs - ; let tyvars = [ mkTyVar name (tyVarKind tv) - | (name,tv) <- arg_names `zip` dataConTyVars con] - arg_tys = dataConInstArgTys con (mkTyVarTys tyvars) - id_names = dropList tyvars arg_names - arg_ids = ASSERT2( equalLength id_names arg_tys, - ppr (con, arg_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_occs rhs - = do { arg_names <- newIfaceNames arg_occs - ; 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_occs $$ 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} @@ -841,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 @@ -882,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 @@ -931,16 +962,16 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a +bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a bindIfaceId (occ, ty) thing_inside - = do { name <- newIfaceName occ + = do { name <- newIfaceName (mkVarOccFS occ) ; ty' <- tcIfaceType ty ; let { id = mkLocalId name ty' } ; extendIfaceIdEnv [id] (thing_inside id) } -bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a bindIfaceIds bndrs thing_inside - = do { names <- newIfaceNames occs + = do { names <- newIfaceNames (map mkVarOccFS occs) ; tys' <- mappM tcIfaceType tys ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' } ; extendIfaceIdEnv ids (thing_inside ids) } @@ -949,28 +980,31 @@ bindIfaceIds bndrs thing_inside ----------------------- -newExtCoreBndr :: (OccName, IfaceType) -> IfL Id -newExtCoreBndr (occ, ty) +newExtCoreBndr :: IfaceIdBndr -> IfL Id +newExtCoreBndr (var, ty) = do { mod <- getIfModule - ; name <- newGlobalBinder mod occ Nothing noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } ----------------------- bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName occ - ; let tyvar = mk_iface_tyvar name kind + = do { name <- newIfaceName (mkTyVarOcc occ) + ; 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 occs - ; let tyvars = zipWith mk_iface_tyvar names kinds + = do { names <- newIfaceNames (map mkTyVarOcc occs) + ; 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}