X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=93452082e1f369786071829e4aa67a3670f555bf;hp=caff95f6e90ffaa529f2f060bfe58881fb1a99ec;hb=e2782137c799a08711cac0844418cc0345a7ceb5;hpb=39dd1943735841b6cc62c91134189371ba571f38 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index caff95f..9345208 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1,65 +1,66 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcIfaceSig]{Type checking of type signatures in interface files} + +Type checking of type signatures in interface files \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal, - tcExtCoreBindings + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, + tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadInterface, loadWiredInHomeIface, - loadDecls, findAndReadIface ) -import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, - extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, refineIfaceIdEnv, - newIfaceName, newIfaceNames, ifaceExportNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, - mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) +import LoadIface +import IfaceEnv +import BuildTyCl import TcRnMonad -import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, - mkTyVarTys, ThetaType ) -import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName ) -import HscTypes ( ExternalPackageState(..), - TyThing(..), tyThingClass, tyThingTyCon, - ModIface(..), ModDetails(..), HomeModInfo(..), - emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) -import InstEnv ( Instance(..), mkImportedInstance ) -import Unify ( coreRefineTys ) +import Type +import TypeRep +import HscTypes +import InstEnv +import FamInstEnv import CoreSyn -import CoreUtils ( exprType ) +import CoreUtils import CoreUnfold -import CoreLint ( lintUnfolding ) -import WorkWrap ( mkWrapper ) -import Id ( Id, mkVanillaGlobal, mkLocalId ) -import MkId ( mkFCallId ) -import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), - setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo, - setArityInfo, setInlinePragInfo, setCafInfo, - vanillaIdInfo, newStrictnessInfo ) -import Class ( Class ) -import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConInstArgTys, isVanillaDataCon ) -import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) -import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, - wiredInNameTyThing_maybe, nameParent ) +import CoreLint +import WorkWrap +import Id +import MkId +import IdInfo +import Class +import TyCon +import DataCon +import TysWiredIn +import Var ( TyVar ) +import qualified Var +import VarEnv +import Name import NameEnv -import OccName ( OccName ) -import Module ( Module, lookupModuleEnv ) -import UniqSupply ( initUs_ ) +import OccName +import Module +import UniqFM +import UniqSupply import Outputable -import ErrUtils ( Message ) -import Maybes ( MaybeErr(..) ) -import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, dropList, equalLength ) -import DynFlags ( DynFlag(..), isOneShot ) +import ErrUtils +import Maybes +import SrcLoc +import DynFlags +import Control.Monad + +import Data.List +import Data.Maybe \end{code} This module takes @@ -111,6 +112,7 @@ tcImportDecl :: Name -> TcM TyThing tcImportDecl name | Just thing <- wiredInNameTyThing_maybe name = do { initIfaceTcRn (loadWiredInHomeIface name) + -- See Note [Loading instances] in LoadIface ; return thing } | otherwise = do { traceIf (text "tcImportDecl" <+> ppr name) @@ -121,19 +123,19 @@ tcImportDecl name checkWiredInTyCon :: TyCon -> TcM () -- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. It might not be a wired-in tycon (see the calls in TcUnify), +-- are loaded. See See Note [Loading instances] in LoadIface +-- It might not be a wired-in tycon (see the calls in TcUnify), -- in which case this is a no-op. checkWiredInTyCon tc | not (isWiredInName tc_name) = 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 @@ -159,7 +161,8 @@ importDecl name }}} where nd_doc = ptext SLIT("Need decl for") <+> ppr name - not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name)) + not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> + pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) \end{code} @@ -192,28 +195,36 @@ 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) + + -- Vectorisation information + ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env + (mi_vect_info 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_vect_info = vect_info + , md_exports = exports + } } \end{code} @@ -225,11 +236,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 @@ -245,7 +259,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 +270,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 @@ -337,58 +350,88 @@ 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, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, - ifVrcs = arg_vrcs, ifRec = is_rec, - ifGeneric = want_generic }) + ifRec = is_rec, + ifGeneric = want_generic, + ifFamInst = mb_family }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tycon <- fixM ( \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; famInst <- + case mb_family of + Nothing -> return Nothing + Just (fam, tys) -> + do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) + } + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; buildAlgTyCon tc_name tyvars stupid_theta - cons arg_vrcs is_rec want_generic + cons is_rec want_generic gadt_syn famInst }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) }} -tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) +tcIfaceDecl ignore_prags + (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, + ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty, + ifFamInst = mb_family}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_ty <- tcIfaceType rdr_rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs)) + ; 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 + ; return $ ATyCon tycon } -tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, - ifFDs = rdr_fds, ifSigs = rdr_sigs, - ifVrcs = tc_vrcs, ifRec = tc_isrec }) +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 = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { cls_name <- lookupIfaceTop occ_name ; 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 tc_vrcs + ; 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) = 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] @@ -397,38 +440,42 @@ 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 [])) } + liftedTypeKind 0)) } -tcIfaceDataCons tycon tc_tyvars if_cons +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs + IfOpenDataTyCon -> return mkOpenDataTyConRhs IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con - ; return (mkNewTyConRhs tycon data_con) } + ; mkNewTyConRhs tycon_name tycon data_con } where - tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, - ifConStricts = stricts, ifConFields = field_lbls}) - = do { name <- lookupIfaceTop occ - -- Read the argument types, but lazily to avoid faulting in - -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; lbl_names <- mappM lookupIfaceTop field_lbls - ; buildDataCon name is_infix True {- Vanilla -} - stricts lbl_names - tc_tyvars [] arg_tys tycon - (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys - } - - tc_con_decl (IfGadtCon { ifConTyVars = con_tvs, - ifConOcc = occ, ifConCtxt = ctxt, - ifConArgTys = args, ifConResTys = ress, - ifConStricts = stricts}) - = bindIfaceTyVars con_tvs $ \ con_tyvars -> do + tc_con_decl (IfCon { ifConInfix = is_infix, + ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, + ifConArgTys = args, ifConFields = field_lbls, + ifConStricts = stricts}) + = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do + bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { name <- lookupIfaceTop occ + ; eq_spec <- tcIfaceEqSpec spec ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here -- At one stage I thought that this context checking *had* -- to be lazy, because of possible mutual recursion between the @@ -442,15 +489,23 @@ tcIfaceDataCons tycon tc_tyvars if_cons -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) - ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress) + ; lbl_names <- mappM lookupIfaceTop field_lbls - ; buildDataCon name False {- Not infix -} False {- Not vanilla -} - stricts [{- No fields -}] - con_tyvars theta - arg_tys tycon res_tys + ; buildDataCon name is_infix {- Not infix -} + stricts lbl_names + univ_tyvars ex_tyvars + eq_spec theta + arg_tys tycon } mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name -\end{code} + +tcIfaceEqSpec spec + = mapM do_item spec + where + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ) + ; ty <- tcIfaceType if_ty + ; return (tv,ty) } +\end{code} %************************************************************************ @@ -465,13 +520,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' 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} @@ -486,24 +547,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 + ; 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 = isLocalIfaceExtName fn }) } + 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 @@ -512,19 +581,105 @@ 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} %************************************************************************ %* * + Vectorisation information +%* * +%************************************************************************ + +\begin{code} +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceVectInfo mod typeEnv (IfaceVectInfo + { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + }) + = do { vVars <- mapM vectVarMapping vars + ; tyConRes1 <- mapM vectTyConMapping tycons + ; tyConRes2 <- mapM vectTyConReuseMapping tycons + ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2) + ; return $ VectInfo + { vectInfoVar = mkVarEnv vVars + , vectInfoTyCon = mkNameEnv vTyCons + , vectInfoDataCon = mkNameEnv (concat vDataCons) + , vectInfoPADFun = mkNameEnv vPAs + , vectInfoIso = mkNameEnv vIsos + } + } + where + vectVarMapping name + = do { vName <- lookupOrig mod (mkVectOcc (nameOccName name)) + ; let { var = lookupVar name + ; vVar = lookupVar vName + } + ; return (var, (var, vVar)) + } + vectTyConMapping name + = do { vName <- lookupOrig mod (mkVectTyConOcc (nameOccName name)) + ; paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; vTycon = lookupTyCon vName + ; paTycon = lookupVar paName + ; isoTycon = lookupVar isoName + } + ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon) + ; return ((name, (tycon, vTycon)), -- (T, T_v) + vDataCons, -- list of (Ci, Ci_v) + (vName, (vTycon, paTycon)), -- (T_v, paT) + (name, (tycon, isoTycon))) -- (T, isoT) + } + vectTyConReuseMapping name + = do { paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) + ; let { tycon = lookupTyCon name + ; paTycon = lookupVar paName + ; isoTycon = lookupVar isoName + ; vDataCons = [ (dataConName dc, (dc, dc)) + | dc <- tyConDataCons tycon] + } + ; return ((name, (tycon, tycon)), -- (T, T) + vDataCons, -- list of (Ci, Ci) + (name, (tycon, paTycon)), -- (T, paT) + (name, (tycon, isoTycon))) -- (T, isoT) + } + vectDataConMapping datacon + = do { let name = dataConName datacon + ; vName <- lookupOrig mod (mkVectDataConOcc (nameOccName name)) + ; let vDataCon = lookupDataCon vName + ; return (name, (datacon, vDataCon)) + } + -- + lookupVar name = case lookupTypeEnv typeEnv name of + Just (AnId var) -> var + Just _ -> + panic "TcIface.tcIfaceVectInfo: not an id" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" + lookupTyCon name = case lookupTypeEnv typeEnv name of + Just (ATyCon tc) -> tc + Just _ -> + panic "TcIface.tcIfaceVectInfo: not a tycon" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" + lookupDataCon name = case lookupTypeEnv typeEnv name of + Just (ADataCon dc) -> dc + Just _ -> + panic "TcIface.tcIfaceVectInfo: not a datacon" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" +\end{code} + +%************************************************************************ +%* * Types %* * %************************************************************************ @@ -544,6 +699,7 @@ tcIfaceTypes tys = mapM tcIfaceType tys tcIfacePredType :: IfacePredType -> IfL PredType tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } +tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') } ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType @@ -567,6 +723,10 @@ tcIfaceExpr (IfaceLcl name) = tcIfaceLclId name `thenM` \ id -> returnM (Var id) +tcIfaceExpr (IfaceTick modName tickNo) + = tcIfaceTick modName tickNo `thenM` \ id -> + returnM (Var id) + tcIfaceExpr (IfaceExt gbl) = tcIfaceExtId gbl `thenM` \ id -> returnM (Var id) @@ -603,7 +763,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 @@ -615,42 +775,44 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) -- corresponds to the datacon in this case alternative in extendIfaceIdEnv [case_bndr'] $ - mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - tcIfaceType ty `thenM` \ ty' -> + mappM (tcIfaceAlt scrut' tc_app) alts `thenM` \ alts' -> + tcIfaceType ty `thenM` \ ty' -> 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 +tcIfaceExpr (IfaceCast expr co) = do + expr' <- tcIfaceExpr expr + co' <- tcIfaceType co + returnM (Cast expr' co') + tcIfaceExpr (IfaceNote note expr) = tcIfaceExpr expr `thenM` \ expr' -> case note of - 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') ------------------------- -tcIfaceAlt _ (IfaceDefault, names, rhs) +tcIfaceAlt _ _ (IfaceDefault, names, rhs) = ASSERT( null names ) tcIfaceExpr rhs `thenM` \ rhs' -> returnM (DEFAULT, [], rhs') -tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) +tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) = ASSERT( null names ) tcIfaceExpr rhs `thenM` \ rhs' -> returnM (LitAlt lit, [], rhs') @@ -658,51 +820,30 @@ 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) - = 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) ) +tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) + = do { con <- tcIfaceDataCon data_occ +#ifdef DEBUG + ; ifM (not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) +#endif + ; tcIfaceDataAlt con inst_tys arg_strs rhs } - if isVanillaDataCon con then - tcVanillaAlt con inst_tys arg_occs rhs - else - do { -- General case - arg_names <- newIfaceNames arg_occs - ; let tyvars = [ mkTyVar name (tyVarKind tv) - | (name,tv) <- arg_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 ) - zipWith mkLocalId id_names arg_tys - - Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys) - - ; rhs' <- extendIfaceTyVarEnv tyvars $ - extendIfaceIdEnv arg_ids $ - refineIfaceIdEnv refine $ - -- You might think that we don't need to refine the envt here, - -- but we do: \(x::a) -> case y of - -- MkT -> case x of { True -> ... } - -- In the "case x" we need to know x's type, because we use that - -- to find which module to look for "True" in. Sigh. - tcIfaceExpr rhs - ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} - -tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) +tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) = ASSERT( isTupleTyCon tycon ) 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 - ; 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 ) - zipWith mkLocalId arg_names arg_tys - ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs) - ; returnM (DataAlt data_con, arg_ids, rhs') } + ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } + +tcIfaceDataAlt con inst_tys arg_strs rhs + = do { us <- newUniqueSupply + ; let uniqs = uniqsFromSupply us + ; let (ex_tvs, co_tvs, arg_ids) + = dataConRepFSInstPat arg_strs uniqs con inst_tys + all_tvs = ex_tvs ++ co_tvs + + ; rhs' <- extendIfaceTyVarEnv all_tvs $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, all_tvs ++ arg_ids, rhs') } \end{code} @@ -737,9 +878,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 @@ -807,7 +951,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' @@ -836,18 +980,10 @@ 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 - ; case lookupType hpt (eps_PTE eps) name of { - Just thing -> return thing ; - Nothing -> do - - { env <- getGblEnv - ; case if_rec_types env of { + = do { env <- getGblEnv + ; case if_rec_types env of { -- Note [Tying the knot] Just (mod, get_type_env) | nameIsLocalOrFrom mod name -> do -- It's defined in the module being compiled @@ -859,12 +995,49 @@ tcIfaceGlobal name ; other -> do + { (eps,hpt) <- getEpsAndHpt + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { + Just thing -> return thing ; + Nothing -> do + { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of Failed err -> failIfM err Succeeded thing -> return thing }}}}} +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used in two situations: +-- +-- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T +-- Then we look up M.T in M's type environment, which is splatted into if_rec_types +-- after we've built M's type envt. +-- +-- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi +-- is up to date. So we call typecheckIface on M.hi. This splats M.T into +-- if_rec_types so that the (lazily typechecked) decls see all the other decls +-- +-- In case (b) it's important to do the if_rec_types check *before* looking in the HPT +-- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its +-- emasculated form (e.g. lacking data constructors). + +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 +-- See Note [Loading instances] in LoadIface +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 @@ -872,43 +1045,45 @@ 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 check_tc tc = tc #endif +-- we should be okay just returning Kind constructors without extra loading +tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon +tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon +tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon +tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon +tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- Even though we are in an interface file, we want to make -- 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} %************************************************************************ @@ -919,8 +1094,11 @@ tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl \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 @@ -932,46 +1110,50 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a -bindIfaceId (occ, ty) thing_inside - = do { name <- newIfaceName 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 :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a -bindIfaceIds bndrs thing_inside - = do { names <- newIfaceNames 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 :: (OccName, IfaceType) -> IfL Id -newExtCoreBndr (occ, ty) +newExtCoreBndr :: IfaceLetBndr -> IfL Id +newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now = do { mod <- getIfModule - ; name <- newGlobalBinder mod occ Nothing noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcSpan ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } ----------------------- bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName occ - ; let tyvar = mk_iface_tyvar name kind + = do { name <- newIfaceName (mkTyVarOcc 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 occs - ; let tyvars = zipWith mk_iface_tyvar names kinds + = do { names <- newIfaceNames (map mkTyVarOcc occs) + ; tyvars <- TcRnMonad.zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where (occs,kinds) = unzip bndrs -mk_iface_tyvar name kind = mkTyVar name kind +mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar +mk_iface_tyvar name ifKind + = do { kind <- tcIfaceType ifKind + ; if isCoercionKind kind then + return (Var.mkCoVar name kind) + else + return (Var.mkTyVar name kind) } \end{code}