X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=92d39978985656770ea286d3fe1d2acdaf73e0e1;hb=c860699ce51ab92e85ee30c6afe555fc345f4c37;hp=b902c8c5fe6281fa0d0f8637bcee4c2a2ed9a1f8;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index b902c8c..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 @@ -639,7 +642,6 @@ tcIfaceExpr (IfaceNote note expr) IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> returnM (Note (Coerce to_ty' (exprType expr')) expr') - IfaceInlineCall -> returnM (Note InlineCall expr') IfaceInlineMe -> returnM (Note InlineMe expr') IfaceSCC cc -> returnM (Note (SCC cc) expr') IfaceCoreNote n -> returnM (Note (CoreNote n) expr') @@ -658,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) @@ -695,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') } @@ -751,7 +754,8 @@ tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info -- The next two are lazy, so they don't transitively suck stuff in tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity - tcPrag info (HsUnfold inline_prag expr) + tcPrag info (HsInline inline_prag) = returnM (info `setInlinePragInfo` inline_prag) + tcPrag info (HsUnfold expr) = tcPragExpr name expr `thenM` \ maybe_expr' -> let -- maybe_expr' doesn't get looked at if the unfolding @@ -760,8 +764,7 @@ tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info Nothing -> noUnfolding Just expr' -> mkTopUnfolding expr' in - returnM (info `setUnfoldingInfoLazily` unfold_info - `setInlinePragInfo` inline_prag) + returnM (info `setUnfoldingInfoLazily` unfold_info) \end{code} \begin{code} @@ -842,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 @@ -932,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) } @@ -950,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