X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fiface%2FTcIface.lhs;h=a90d069d1c4cd0ca83c72abcbc04d333ef8e0afc;hb=e5f78a4a5309b598d5195aa49a0bf7a206942cea;hp=42321955e65a9abf76387a318d3972acd2c9dee5;hpb=9a8c922e5beacdf8969f1d6d6878f5e5812d3bf8;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 4232195..a90d069 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -40,6 +40,7 @@ import Var ( TyVar ) import qualified Var import Name import NameEnv +import NameSet import OccName import Module import UniqFM @@ -48,7 +49,6 @@ import Outputable import ErrUtils import Maybes import SrcLoc -import Util import DynFlags import Control.Monad @@ -199,6 +199,10 @@ typecheckIface iface ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + -- Vectorisation information + ; let vect_info = VectInfo + (mkNameSet (ifaceVectInfoCCVar (mi_vect_info iface))) + -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -209,7 +213,9 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules - , md_exports = exports + , md_vect_info = vect_info + , md_exports = exports + , md_modBreaks = emptyModBreaks } } \end{code} @@ -222,11 +228,14 @@ typecheckIface iface %************************************************************************ \begin{code} -tcHiBootIface :: Module -> TcRn ModDetails +tcHiBootIface :: HscSource -> Module -> TcRn ModDetails -- Load the hi-boot iface for the module being compiled, -- if it indeed exists in the transitive closure of imports -- Return the ModDetails, empty if no hi-boot iface -tcHiBootIface mod +tcHiBootIface hsc_src mod + | isHsBoot hsc_src -- Already compiling a hs-boot file + = return emptyModDetails + | otherwise = do { traceIf (text "loadHiBootInterface" <+> ppr mod) ; mode <- getGhcMode @@ -378,9 +387,11 @@ tcIfaceDecl ignore_prags = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_tyki <- tcIfaceType rdr_rhs_ty - ; let rhs = if isOpen then OpenSynTyCon rhs_tyki + ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing else SynonymTyCon rhs_tyki - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) + -- !!!TODO: read mb_family info from iface and pass as last argument + ; tycon <- buildSynTyCon tc_name tyvars rhs Nothing + ; return $ ATyCon tycon } tcIfaceDecl ignore_prags @@ -404,8 +415,8 @@ tcIfaceDecl ignore_prags = do { op_name <- lookupIfaceTop occ ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty) -- Must be done lazily for just the same reason as the - -- context of a data decl: the type sig might mention the - -- class being defined + -- type of a data con; to avoid sucking in types that + -- it mentions unless it's necessray to do so ; return (op_name, dm, op_ty) } mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty] @@ -497,7 +508,7 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedInstance cls mb_tcs' orph dfun oflag) } + ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, @@ -542,12 +553,13 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args ; lcl <- getLclEnv - ; let this_module = if_mod lcl ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', - ru_rhs = rhs', ru_orph = orph, + ru_rhs = rhs', ru_rough = mb_tcs, - ru_local = nameModule fn == this_module }) } + ru_local = False }) } -- An imported RULE is never for a local Id + -- or, even if it is (module loop, perhaps) + -- we'll just leave it in the non-local set where -- This function *must* mirror exactly what Rules.topFreeName does -- We could have stored the ru_rough field in the iface file @@ -662,16 +674,17 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) - = tcIfaceExpr rhs `thenM` \ rhs' -> - bindIfaceId bndr $ \ bndr' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Let (NonRec bndr' rhs') body') + = do { rhs' <- tcIfaceExpr rhs + ; id <- tcIfaceLetBndr bndr + ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + ; return (Let (NonRec id rhs') body') } tcIfaceExpr (IfaceLet (IfaceRec pairs) body) - = bindIfaceIds bndrs $ \ bndrs' -> - mappM tcIfaceExpr rhss `thenM` \ rhss' -> - tcIfaceExpr body `thenM` \ body' -> - returnM (Let (Rec (bndrs' `zip` rhss')) body') + = do { ids <- mapM tcIfaceLetBndr bndrs + ; extendIfaceIdEnv ids $ do + { rhss' <- mapM tcIfaceExpr rhss + ; body' <- tcIfaceExpr body + ; return (Let (Rec (ids `zip` rhss')) body') } } where (bndrs, rhss) = unzip pairs @@ -956,8 +969,11 @@ tcIfaceExtId name = do { thing <- tcIfaceGlobal name \begin{code} bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a -bindIfaceBndr (IfaceIdBndr bndr) thing_inside - = bindIfaceId bndr thing_inside +bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; let id = mkLocalId name ty' + ; extendIfaceIdEnv [id] (thing_inside id) } bindIfaceBndr (IfaceTvBndr bndr) thing_inside = bindIfaceTyVar bndr thing_inside @@ -969,26 +985,24 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a -bindIfaceId (occ, ty) thing_inside - = do { name <- newIfaceName (mkVarOccFS occ) +tcIfaceLetBndr (IfLetBndr fs ty info) + = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; let { id = mkLocalId name ty' } - ; extendIfaceIdEnv [id] (thing_inside id) } - -bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a -bindIfaceIds bndrs thing_inside - = do { names <- newIfaceNames (map mkVarOccFS occs) - ; tys' <- mappM tcIfaceType tys - ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' } - ; extendIfaceIdEnv ids (thing_inside ids) } + ; case info of + NoInfo -> return (mkLocalId name ty') + HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) } where - (occs,tys) = unzip bndrs - + -- Similar to tcIdInfo, but much simpler + tc_info [] = vanillaIdInfo + tc_info (HsInline p : i) = tc_info i `setInlinePragInfo` p + tc_info (HsArity a : i) = tc_info i `setArityInfo` a + tc_info (HsStrictness s : i) = tc_info i `setAllStrictnessInfo` Just s + tc_info (other : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" + (ppr other) (tc_info i) ----------------------- -newExtCoreBndr :: IfaceIdBndr -> IfL Id -newExtCoreBndr (var, ty) +newExtCoreBndr :: IfaceLetBndr -> IfL Id +newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now = do { mod <- getIfModule ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc ; ty' <- tcIfaceType ty