X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=48ca729f665a2c58086c3e32eb4ea057a6dc438f;hb=0bff4d75254dabb2c002eace2252a4480bf8474e;hp=2dcdf78bd3f5049c5ee7ccca2766fec16e2734cc;hpb=6084fb5517da34f65034370a3695e2af3b85ce2b;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2dcdf78..48ca729 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -9,7 +9,7 @@ Type checking of type signatures in interface files module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, - tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings + tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" @@ -22,6 +22,7 @@ import TcRnMonad import Type import TypeRep import HscTypes +import Annotations import InstEnv import FamInstEnv import CoreSyn @@ -52,7 +53,6 @@ import SrcLoc import DynFlags import Util import FastString -import BasicTypes (Arity) import Control.Monad import Data.List @@ -68,7 +68,7 @@ This module takes An IfaceDecl is populated with RdrNames, and these are not renamed to Names before typechecking, because there should be no scope errors etc. - -- For (b) consider: f = $(...h....) + -- For (b) consider: f = \$(...h....) -- where h is imported, and calls f via an hi-boot file. -- This is bad! But it is not seen as a staging error, because h -- is indeed imported. We don't want the type-checker to black-hole @@ -127,7 +127,8 @@ checkWiredInTyCon tc = return () | otherwise = do { mod <- getModule - ; unless (mod == nameModule tc_name) + ; ASSERT( isExternalName tc_name ) + unless (mod == nameModule tc_name) (initIfaceTcRn (loadWiredInHomeIface tc_name)) -- Don't look for (non-existent) Float.hi when -- compiling Float.lhs, which mentions Float of course @@ -144,7 +145,8 @@ importDecl name do { traceIf nd_doc -- Load the interface, which should populate the PTE - ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem + ; mb_iface <- ASSERT2( isExternalName name, ppr name ) + loadInterface nd_doc (nameModule name) ImportBySystem ; case mb_iface of { Failed err_msg -> return (Failed err_msg) ; Succeeded _ -> do @@ -199,10 +201,11 @@ typecheckIface iface ; let type_env = mkNameEnv names_w_things ; writeMutVar tc_env_var type_env - -- Now do those rules and instances + -- Now do those rules, instances and annotations ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env @@ -218,6 +221,7 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules + , md_anns = anns , md_vect_info = vect_info , md_exports = exports } @@ -356,14 +360,13 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdI ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkVanillaGlobalWithInfo name ty info)) } -tcIfaceDecl _ - (IfaceData {ifName = occ_name, - ifTyVars = tv_bndrs, - ifCtxt = ctxt, ifGadtSyntax = gadt_syn, - ifCons = rdr_cons, - ifRec = is_rec, - ifGeneric = want_generic, - ifFamInst = mb_family }) +tcIfaceDecl _ (IfaceData {ifName = occ_name, + ifTyVars = tv_bndrs, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifRec = is_rec, + ifGeneric = want_generic, + ifFamInst = mb_family }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do @@ -385,25 +388,30 @@ tcIfaceDecl _ ; return (ATyCon tycon) }} -tcIfaceDecl _ - (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty, - ifFamInst = mb_family}) +tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, + ifSynRhs = mb_rhs_ty, + ifSynKind = kind, ifFamInst = mb_family}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_tyki <- tcIfaceType rdr_rhs_ty - ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing - else SynonymTyCon rhs_tyki - ; famInst <- case mb_family of - Nothing -> return Nothing - Just (fam, tys) -> - do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) - } - ; tycon <- buildSynTyCon tc_name tyvars rhs famInst + ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] + ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ + do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty + ; fam <- tc_syn_fam mb_family + ; return (rhs, fam) } + ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam ; return $ ATyCon tycon } + where + mk_doc n = ptext (sLit "Type syonym") <+> ppr n + tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing) + tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } + tc_syn_fam Nothing + = return Nothing + tc_syn_fam (Just (fam, tys)) + = do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) } tcIfaceDecl ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, @@ -488,11 +496,15 @@ tcIfaceDataCons tycon_name tycon _ if_cons ; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args) ; lbl_names <- mapM lookupIfaceTop field_lbls + -- Remember, tycon is the representation tycon + ; let orig_res_ty = mkFamilyTyConApp tycon + (substTyVars (mkTopTvSubst eq_spec) univ_tyvars) + ; buildDataCon name is_infix {- Not infix -} stricts lbl_names univ_tyvars ex_tyvars eq_spec theta - arg_tys tycon + arg_tys orig_res_ty tycon } mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name @@ -505,6 +517,23 @@ tcIfaceEqSpec spec ; return (tv,ty) } \end{code} +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (Trac #2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. %************************************************************************ %* * @@ -587,6 +616,34 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd %************************************************************************ %* * + Annotations +%* * +%************************************************************************ + +\begin{code} +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceAnnotations = mapM tcIfaceAnnotation + +tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation +tcIfaceAnnotation (IfaceAnnotation target serialized) = do + target' <- tcIfaceAnnTarget target + return $ Annotation { + ann_target = target', + ann_value = serialized + } + +tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) +tcIfaceAnnTarget (NamedTarget occ) = do + name <- lookupIfaceTop occ + return $ NamedTarget name +tcIfaceAnnTarget (ModuleTarget mod) = do + return $ ModuleTarget mod + +\end{code} + + +%************************************************************************ +%* * Vectorisation information %* * %************************************************************************ @@ -790,7 +847,6 @@ tcIfaceExpr (IfaceCast expr co) = do tcIfaceExpr (IfaceNote note expr) = do expr' <- tcIfaceExpr expr case note of - IfaceInlineMe -> return (Note InlineMe expr') IfaceSCC cc -> return (Note (SCC cc) expr') IfaceCoreNote n -> return (Note (CoreNote n) expr') @@ -880,46 +936,43 @@ tcIdInfo ignore_prags name ty info -- we start; default assumption is that it has CAFs init_info = vanillaIdInfo + tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) -- 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 (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag) - tcPrag info (HsUnfold expr) = do - maybe_expr' <- tcPragExpr name expr - let - -- maybe_expr' doesn't get looked at if the unfolding - -- is never inspected; so the typecheck doesn't even happen - unfold_info = case maybe_expr' of - Nothing -> noUnfolding - Just expr' -> mkTopUnfolding expr' - return (info `setUnfoldingInfoLazily` unfold_info) + tcPrag info (HsUnfold if_unf) = do { unf <- tcUnfolding name ty info if_unf + ; return (info `setUnfoldingInfoLazily` unf) } \end{code} \begin{code} -tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo -tcWorkerInfo ty info wkr arity +tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +tcUnfolding name _ _ (IfCoreUnfold if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkTopUnfolding expr) } + +tcUnfolding name _ _ (IfInlineRule arity if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkInlineRule expr arity) } + +tcUnfolding name ty info (IfWrapper arity wkr) = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) - - -- We return without testing maybe_wkr_id, but as soon as info is - -- looked at we will test it. That's ok, because its outside the - -- knot; and there seems no big reason to further defer the - -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking - -- over the unfolding until it's actually used does seem worth while.) ; us <- newUniqueSupply - ; return (case mb_wkr_id of - Nothing -> info - Just wkr_id -> add_wkr_info us wkr_id info) } + Nothing -> noUnfolding + Just wkr_id -> make_inline_rule wkr_id us) } where - doc = text "Worker for" <+> ppr wkr - add_wkr_info us wkr_id info - = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id - `setWorkerInfo` HasWorker wkr_id arity + doc = text "Worker for" <+> ppr name - mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) + make_inline_rule wkr_id us + = mkWwInlineRule (initUs_ us (mkWrapper ty strict_sig) wkr_id) + arity wkr_id -- We are relying here on strictness info always appearing -- before worker info, fingers crossed .... @@ -985,9 +1038,9 @@ tcIfaceGlobal name ; _ -> do - { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { Just thing -> return thing ; Nothing -> do @@ -1025,7 +1078,8 @@ ifCheckWiredInThing name -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in -- the HPT, so without the test we'll demand-load it into the PIT! -- C.f. the same test in checkWiredInTyCon above - ; unless (mod == nameModule name) + ; ASSERT2( isExternalName name, ppr name ) + unless (mod == nameModule name) (loadWiredInHomeIface name) } tcIfaceTyCon :: IfaceTyCon -> IfL TyCon @@ -1125,13 +1179,13 @@ newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now ----------------------- bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName (mkTyVarOcc occ) + = do { name <- newIfaceName (mkTyVarOccFS 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 (map mkTyVarOcc occs) + = do { names <- newIfaceNames (map mkTyVarOccFS occs) ; tyvars <- zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where