X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=92d39978985656770ea286d3fe1d2acdaf73e0e1;hb=c860699ce51ab92e85ee30c6afe555fc345f4c37;hp=7c4c5354c6252b36975257d524b51c32a821d63d;hpb=f2dcf256399e9a2de6343c625630b51f8abf4863;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7c4c535..92d3997 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -51,14 +51,16 @@ import Var ( TyVar, mkTyVar, tyVarKind ) import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv -import OccName ( OccName ) -import Module ( Module, lookupModuleEnv ) +import OccName ( OccName, mkVarOccFS, mkTyVarOcc ) +import FastString ( FastString ) +import Module ( Module, moduleName ) +import UniqFM ( lookupUFM ) import UniqSupply ( initUs_ ) import Outputable import ErrUtils ( Message ) import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, dropList, equalLength ) +import Util ( zipWithEqual, equalLength, splitAtList ) import DynFlags ( DynFlag(..), isOneShot ) \end{code} @@ -245,7 +247,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 +258,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 @@ -375,6 +376,8 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, ifFDs = rdr_fds, ifSigs = rdr_sigs, ifVrcs = tc_vrcs, 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 @@ -603,7 +606,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 @@ -657,23 +660,24 @@ 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) ) if isVanillaDataCon con then - tcVanillaAlt con inst_tys arg_occs rhs + tcVanillaAlt con inst_tys arg_strs rhs else do { -- General case - arg_names <- newIfaceNames arg_occs + 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) <- arg_names `zip` dataConTyVars con] + | (name,tv) <- tyvar_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 ) + 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) @@ -694,11 +698,11 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) 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 +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_occs $$ ppr rhs ) + 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') } @@ -841,7 +845,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 @@ -931,16 +936,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,23 +954,23 @@ 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 + = do { name <- newIfaceName (mkTyVarOcc occ) ; let 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 + = do { names <- newIfaceNames (map mkTyVarOcc occs) ; let tyvars = zipWith mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where