X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=c16846ec288fa946c59ab588a9ef84c3958ea4bb;hp=2831c2dda737ae91215bad8ed458457d9f29ba7c;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hpb=909d2dd885f5eebaf7c12cf15d5ac153d646566e diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2831c2d..c16846e 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -6,18 +6,17 @@ \begin{code} module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal, + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadInterface, loadWiredInHomeIface, - loadDecls, findAndReadIface ) -import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, +import LoadIface ( loadInterface, loadWiredInHomeIface, findAndReadIface, loadDecls ) +import IfaceEnv ( lookupIfaceTop, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, + tcIfaceTyVar, tcIfaceLclId, newIfaceName, newIfaceNames, ifaceExportNames ) import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, @@ -27,16 +26,16 @@ import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, liftedTypeKindTyCon, unliftedTypeKindTyCon, openTypeKindTyCon, argTypeKindTyCon, - ubxTupleKindTyCon, - mkTyVarTys, ThetaType ) + ubxTupleKindTyCon, ThetaType ) import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName, SynTyConRhs(..), - AlgTyConParent(..) ) +import TyCon ( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss ) import HscTypes ( ExternalPackageState(..), TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), HomeModInfo(..), - emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) + emptyModDetails, lookupTypeEnv, lookupType, + typeEnvIds ) import InstEnv ( Instance(..), mkImportedInstance ) +import FamInstEnv ( FamInst(..), mkImportedFamInst ) import CoreSyn import CoreUtils ( exprType, dataConRepFSInstPat ) import CoreUnfold @@ -50,15 +49,14 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConExTyVars, dataConInstArgTys ) +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, nameOccName, wiredInNameTyThing_maybe ) import NameEnv import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, pprNameSpace, occNameFS ) -import FastString ( FastString ) import Module ( Module, moduleName ) import UniqFM ( lookupUFM ) import UniqSupply ( initUs_, uniqsFromSupply ) @@ -66,10 +64,12 @@ import Outputable import ErrUtils ( Message ) import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, equalLength, splitAtList ) +import Util ( zipWithEqual ) import DynFlags ( DynFlag(..), isOneShot ) +import Control.Monad ( unless ) -import Monad ( liftM ) +import List ( elemIndex) +import Maybe ( catMaybes ) \end{code} This module takes @@ -138,12 +138,11 @@ checkWiredInTyCon tc = return () | otherwise = do { mod <- getModule - ; if nameIsLocalOrFrom mod tc_name then + ; 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 - return () - else -- A bit yukky to call initIfaceTcRn here - initIfaceTcRn (loadWiredInHomeIface tc_name) + -- A bit yukky to call initIfaceTcRn here } where tc_name = tyConName tc @@ -203,28 +202,31 @@ typecheckIface iface -- to handle unboxed tuples, so it must not see unfoldings. ignore_prags <- doptM Opt_IgnoreInterfacePragmas - -- Load & typecheck the decls - ; decl_things <- loadDecls ignore_prags (mi_decls iface) - - ; let type_env = mkNameEnv decl_things + -- Typecheck the decls. This is done lazily, so that the knot-tying + -- within this single module work out right. In the If monad there is + -- no global envt for the current interface; instead, the knot is tied + -- through the if_rec_types field of IfGblEnv + ; names_w_things <- loadDecls ignore_prags (mi_decls iface) + ; let type_env = mkNameEnv names_w_things ; writeMutVar tc_env_var type_env -- Now do those rules and instances - ; let { rules | ignore_prags = [] - | otherwise = mi_rules iface - ; dfuns = mi_insts iface - } - ; dfuns <- mapM tcIfaceInst dfuns - ; rules <- mapM tcIfaceRule rules + ; insts <- mapM tcIfaceInst (mi_insts iface) + ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) -- Exports - ; exports <- ifaceExportNames (mi_exports iface) + ; exports <- ifaceExportNames (mi_exports iface) -- Finished - ; return (ModDetails { md_types = type_env, - md_insts = dfuns, - md_rules = rules, - md_exports = exports }) + ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), + text "Type envt:" <+> ppr type_env]) + ; return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_exports = exports + } } \end{code} @@ -347,15 +349,18 @@ the forkM stuff. \begin{code} -tcIfaceDecl :: IfaceDecl -> IfL TyThing +tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing -tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) +tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type - ; info <- tcIdInfo name ty info + ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkVanillaGlobal name ty info)) } -tcIfaceDecl (IfaceData {ifName = occ_name, +tcIfaceDecl ignore_prags + (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, @@ -383,7 +388,8 @@ tcIfaceDecl (IfaceData {ifName = occ_name, ; return (ATyCon tycon) }} -tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, +tcIfaceDecl ignore_prags + (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name @@ -393,8 +399,10 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) } -tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, - ifFDs = rdr_fds, ifSigs = rdr_sigs, +tcIfaceDecl ignore_prags + (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 @@ -403,7 +411,9 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; 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 + ; ats' <- mappM (tcIfaceDecl ignore_prags) 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) @@ -420,7 +430,20 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd ; tvs2' <- mappM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } -tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) + -- 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 ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0)) } @@ -488,13 +511,19 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, ifInstCls = cls, ifInstTys = mb_tcs, ifInstOrph = orph }) = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ - tcIfaceExtId (LocalTop dfun_occ) - ; cls' <- lookupIfaceExt cls - ; mb_tcs' <- mapM do_tc mb_tcs - ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) } - where - do_tc Nothing = return Nothing - do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } + tcIfaceExtId dfun_occ + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' orph dfun oflag) } + +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, + ifFamInstFam = fam, ifFamInstTys = mb_tcs }) +-- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $ +-- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! + = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ + tcIfaceTyCon tycon + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' tycon') } \end{code} @@ -509,24 +538,32 @@ are in the type environment. However, remember that typechecking a Rule may (as a side effect) augment the type envt, and so we may need to iterate the process. \begin{code} +tcIfaceRules :: Bool -- True <=> ignore rules + -> [IfaceRule] + -> IfL [CoreRule] +tcIfaceRules ignore_prags if_rules + | ignore_prags = return [] + | otherwise = mapM tcIfaceRule if_rules + tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, ifRuleOrph = orph }) - = do { fn' <- lookupIfaceExt fn - ; ~(bndrs', args', rhs') <- + = do { ~(bndrs', args', rhs') <- -- Typecheck the payload lazily, in the hope it'll never be looked at forkM (ptext SLIT("Rule") <+> ftext name) $ bindIfaceBndrs bndrs $ \ bndrs' -> do { args' <- mappM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs ; return (bndrs', args', rhs') } - ; mb_tcs <- mapM ifTopFreeName args - ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act, + ; 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_rough = mb_tcs, - ru_local = isLocalIfaceExtName fn }) } + ru_local = nameModule fn == this_module }) } where -- This function *must* mirror exactly what Rules.topFreeName does -- We could have stored the ru_rough field in the iface file @@ -535,14 +572,11 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- type syononyms at the top of a type arg. Since -- we can't tell at this point, we are careful not -- to write them out in coreRuleToIfaceRule - ifTopFreeName :: IfaceExpr -> IfL (Maybe Name) - ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) - = do { n <- lookupIfaceTc tc - ; return (Just n) } - ifTopFreeName (IfaceApp f a) = ifTopFreeName f - ifTopFreeName (IfaceExt ext) = do { n <- lookupIfaceExt ext - ; return (Just n) } - ifTopFreeName other = return Nothing + ifTopFreeName :: IfaceExpr -> Maybe Name + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceApp f a) = ifTopFreeName f + ifTopFreeName (IfaceExt n) = Just n + ifTopFreeName other = Nothing \end{code} @@ -684,8 +718,7 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- 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_strs, rhs) - = do { let tycon_mod = nameModule (tyConName tycon) - ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) + = do { con <- tcIfaceDataCon data_occ ; ASSERT2( con `elem` tyConDataCons tycon, ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) tcIfaceDataAlt con inst_tys arg_strs rhs } @@ -740,9 +773,12 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} -tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo -tcIdInfo name ty NoInfo = return vanillaIdInfo -tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info +tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo +tcIdInfo ignore_prags name ty info + | ignore_prags = return vanillaIdInfo + | otherwise = case info of + NoInfo -> return vanillaIdInfo + HasInfo info -> foldlM tcPrag init_info info where -- Set the CgInfo to something sensible but uninformative before -- we start; default assumption is that it has CAFs @@ -810,7 +846,7 @@ tcPragExpr name expr get_in_scope_ids `thenM` \ in_scope -> case lintUnfolding noSrcLoc in_scope core_expr' of Nothing -> returnM () - Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg) + Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg) ) `thenM_` returnM core_expr' @@ -839,10 +875,7 @@ tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name -- Wired-in things include TyCons, DataCons, and Ids - = do { loadWiredInHomeIface name; return thing } - -- Even though we are in an interface file, we want to make - -- sure its instances are loaded (imagine f :: Double -> Double) - -- and its RULES are loaded too + = do { ifCheckWiredInThing name; return thing } | otherwise = do { (eps,hpt) <- getEpsAndHpt ; dflags <- getDOpts @@ -869,6 +902,20 @@ tcIfaceGlobal name Succeeded thing -> return thing }}}}} +ifCheckWiredInThing :: Name -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +ifCheckWiredInThing name + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- 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) + (loadWiredInHomeIface name) } + tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon @@ -876,12 +923,11 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) -tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm - ; thing <- tcIfaceGlobal name +tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where #ifdef DEBUG - check_tc tc = case toIfaceTyCon (error "urk") tc of + check_tc tc = case toIfaceTyCon tc of IfaceTc _ -> tc other -> pprTrace "check_tc" (ppr tc) tc #else @@ -898,27 +944,24 @@ tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- sure the instances and RULES of this tycon are loaded -- Imagine: f :: Double -> Double tcWiredInTyCon :: TyCon -> IfL TyCon -tcWiredInTyCon tc = do { loadWiredInHomeIface (tyConName tc) +tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc) ; return tc } -tcIfaceClass :: IfaceExtName -> IfL Class -tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name - ; thing <- tcIfaceGlobal name - ; return (tyThingClass thing) } +tcIfaceClass :: Name -> IfL Class +tcIfaceClass name = do { thing <- tcIfaceGlobal name + ; return (tyThingClass thing) } -tcIfaceDataCon :: IfaceExtName -> IfL DataCon -tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of +tcIfaceDataCon :: Name -> IfL DataCon +tcIfaceDataCon name = do { thing <- tcIfaceGlobal name + ; case thing of ADataCon dc -> return dc - other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) } + other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } -tcIfaceExtId :: IfaceExtName -> IfL Id -tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of +tcIfaceExtId :: Name -> IfL Id +tcIfaceExtId name = do { thing <- tcIfaceGlobal name + ; case thing of AnId id -> return id - other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) } + other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } \end{code} %************************************************************************ @@ -963,7 +1006,7 @@ bindIfaceIds bndrs thing_inside newExtCoreBndr :: IfaceIdBndr -> IfL Id newExtCoreBndr (var, ty) = do { mod <- getIfModule - ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') }