X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=6726adfaf9e5017790ffd0289519200fa5300f1d;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=1eb7982cce7fd10e9444e723df205fc2e6d4a2d6;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 1eb7982..6726adf 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -5,40 +5,37 @@ \begin{code} module TcIface ( - tcImportDecl, typecheckIface, - loadImportedInsts, loadImportedRules, + tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal, tcExtCoreBindings ) where + #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadHomeInterface, predInstGates ) -import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig, +import LoadIface ( loadInterface, loadWiredInHomeIface, + loadDecls, findAndReadIface ) +import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId, - tcIfaceDataCon, tcIfaceLclId, - newIfaceName, newIfaceNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass ) + tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, + newIfaceName, newIfaceNames, ifaceExportNames ) +import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, + mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad -import Type ( Kind, openTypeKind, liftedTypeKind, - unliftedTypeKind, mkArrowKind, splitTyConApp, - mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred ) +import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, + mkTyVarTys, ThetaType ) import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) -import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase, - HscEnv, TyThing(..), implicitTyThings, typeEnvIds, - ModIface(..), ModDetails(..), InstPool, ModGuts, - TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv, - RulePool, Pool(..) ) -import InstEnv ( extendInstEnv ) +import HscTypes ( ExternalPackageState(..), + TyThing(..), tyThingClass, tyThingTyCon, + ModIface(..), ModDetails(..), HomeModInfo(..), + emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) +import InstEnv ( Instance(..), mkImportedInstance ) import CoreSyn -import PprCore ( pprIdRules ) -import Rules ( extendRuleBaseList ) import CoreUtils ( exprType ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import InstEnv ( DFunId ) import Id ( Id, mkVanillaGlobal, mkLocalId ) import MkId ( mkFCallId ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), @@ -46,21 +43,22 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), setArityInfo, setInlinePragInfo, setCafInfo, vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) -import TyCon ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon ) -import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys ) -import TysWiredIn ( tupleCon ) +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, NamedThing(..), nameModuleName, nameModule, nameOccName, - isWiredInName, wiredInNameTyThing_maybe, nameParent ) +import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, + wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) -import Module ( Module, ModuleName, moduleName ) +import Module ( Module, lookupModuleEnv ) import UniqSupply ( initUs_ ) import Outputable +import ErrUtils ( Message ) +import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, dropList, equalLength, zipLazy ) -import Maybes ( expectJust ) -import CmdLineOpts ( DynFlag(..) ) +import Util ( zipWithEqual, dropList, equalLength ) +import DynFlags ( DynFlag(..), isOneShot ) \end{code} This module takes @@ -107,109 +105,62 @@ where the code that e1 expands to might import some defns that also turn out to be needed by the code that e2 expands to. \begin{code} -tcImportDecl :: Name -> IfG TyThing --- Get the TyThing for this Name from an interface file -tcImportDecl name - = do { - -- Make sure the interface is loaded - ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name } - ; traceIf (nd_doc <+> char '{') -- Brace matches the later message - ; loadHomeInterface nd_doc name - - -- Get the real name of the thing, with a correct nameParent field. - -- Before the interface is loaded, we may have a non-committal 'Nothing' - -- in the namePareent field (made up by IfaceEnv.lookupOrig), but - -- loading the interface updates the name cache. - -- We need the right nameParent field in getThing - ; real_name <- lookupOrig (nameModuleName name) (nameOccName name) - - -- Get the decl out of the EPS - ; main_thing <- ASSERT( real_name == name ) -- Unique should not change! - getThing real_name - - -- Record the import in the type env, - -- slurp any rules it allows in - ; recordImportOf main_thing - - ; let { extra | getName main_thing == real_name = empty - | otherwise = brackets (ptext SLIT("when seeking") <+> ppr real_name) } - ; traceIf (ptext SLIT(" ...imported decl for") <+> ppr main_thing <+> extra <+> char '}') - - - -- Look up the wanted Name in the type envt; it might be - -- one of the subordinate members of the input thing - ; if real_name == getName main_thing - then return main_thing - else do - { eps <- getEps - ; return (expectJust "tcImportDecl" $ - lookupTypeEnv (eps_PTE eps) real_name) }} - -recordImportOf :: TyThing -> IfG () --- Update the EPS to record the import of the Thing --- (a) augment the type environment; this is done even for wired-in --- things, so that we don't go through this rigmarole a second time --- (b) slurp in any rules to maintain the invariant that any rule --- whose gates are all in the type envt, is in eps_rule_base - -recordImportOf thing - = do { new_things <- updateEps (\ eps -> - let { new_things = thing : implicitTyThings thing - ; new_type_env = extendTypeEnvList (eps_PTE eps) new_things - -- NB: opportunity for a very subtle loop here! - -- If working out what the implicitTyThings are involves poking - -- any of the fork'd thunks in 'thing', then here's what happens - -- * recordImportOf succeed, extending type-env with a thunk - -- * the next guy to pull on type-env forces the thunk - -- * which pokes the suspended forks - -- * which, to execute, need to consult type-env (to check - -- entirely unrelated types, perhaps) - } - in (eps { eps_PTE = new_type_env }, new_things) - ) - ; traceIf (text "tcImport: extend type env" <+> ppr new_things) +tcImportDecl :: Name -> TcM TyThing +-- Entry point for *source-code* uses of importDecl +tcImportDecl name + | Just thing <- wiredInNameTyThing_maybe name + = do { initIfaceTcRn (loadWiredInHomeIface name) + ; return thing } + | otherwise + = do { traceIf (text "tcImportDecl" <+> ppr name) + ; mb_thing <- initIfaceTcRn (importDecl name) + ; case mb_thing of + Succeeded thing -> return thing + Failed err -> failWithTc err } + +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), +-- 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 + -- 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) } - -getThing :: Name -> IfG TyThing --- Find and typecheck the thing; the Name might be a "subordinate name" --- of the "main thing" (e.g. the constructor of a data type declaration) --- The Thing we return is the parent "main thing" + where + tc_name = tyConName tc -getThing name - | Just thing <- wiredInNameTyThing_maybe name - = return thing - - | otherwise = do -- The normal case, not wired in - { -- Get the decl from the pool - mb_decl <- updateEps (\ eps -> selectDecl eps name) - - ; case mb_decl of - Just decl -> initIfaceLcl (nameModuleName name) (tcIfaceDecl decl) - -- Typecheck it - -- Side-effects EPS by faulting in any needed decls - -- (via nested calls to tcImportDecl) - - - Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM } - -- Declaration not found - -- No errors-var to accumulate errors in, so just - -- print out the error right now - - } +importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) +-- Get the TyThing for this Name from an interface file +-- It's not a wired-in thing -- the caller caught that +importDecl name + = ASSERT( not (isWiredInName name) ) + do { traceIf nd_doc + + -- Load the interface, which should populate the PTE + ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem + ; case mb_iface of { + Failed err_msg -> return (Failed err_msg) ; + Succeeded iface -> do + + -- Now look it up again; this time we should find it + { eps <- getEps + ; case lookupTypeEnv (eps_PTE eps) name of + Just thing -> return (Succeeded thing) + Nothing -> return (Failed not_found_msg) + }}} where - msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent 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")]) - -selectDecl :: ExternalPackageState -> Name -> (ExternalPackageState, Maybe IfaceDecl) --- Use nameParent to get the parent name of the thing -selectDecl eps@(EPS { eps_decls = Pool decls_map n_in n_out}) name - = case lookupNameEnv decls_map main_name of - Nothing -> (eps, Nothing) - Just decl -> (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) - where - main_name = nameParent name - decls' = delFromNameEnv decls_map main_name + 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)) + 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} %************************************************************************ @@ -227,37 +178,110 @@ knot. Remember, the decls aren't necessarily in dependency order -- and even if they were, the type decls might be mutually recursive. \begin{code} -typecheckIface :: HscEnv - -> ModIface -- Get the decls from here - -> IO ModDetails -typecheckIface hsc_env iface@(ModIface { mi_module = mod, mi_decls = ver_decls, - mi_rules = rules, mi_insts = dfuns }) - = initIfaceTc hsc_env iface $ \ tc_env_var -> do - { -- Typecheck the decls - names <- mappM (lookupOrig (moduleName mod) . ifName) decls - ; ty_things <- fixM (\ rec_ty_things -> do - { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things)) - -- This only makes available the "main" things, - -- but that's enough for the strictly-checked part - ; mapM tcIfaceDecl decls }) - - -- Now augment the type envt with all the implicit things - -- These will be needed when type-checking the unfoldings for - -- the IfaceIds, but this is done lazily, so writing the thing - -- now is sufficient - ; let { add_implicits main_thing = main_thing : implicitTyThings main_thing - ; type_env = mkTypeEnv (concatMap add_implicits ty_things) } +typecheckIface :: ModIface -- Get the decls from here + -> TcRnIf gbl lcl ModDetails +typecheckIface iface + = initIfaceTc iface $ \ tc_env_var -> do + -- The tc_env_var is freshly allocated, private to + -- type-checking this particular interface + { -- Get the right set of decls and rules. If we are compiling without -O + -- we discard pragmas before typechecking, so that we don't "see" + -- information that we shouldn't. From a versioning point of view + -- It's not actually *wrong* to do so, but in fact GHCi is unable + -- 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 ; writeMutVar tc_env_var type_env -- Now do those rules and instances - ; dfuns <- mapM tcIfaceInst (mi_insts iface) - ; rules <- mapM tcIfaceRule (mi_rules iface) + ; let { rules | ignore_prags = [] + | otherwise = mi_rules iface + ; dfuns = mi_insts iface + } + ; dfuns <- mapM tcIfaceInst dfuns + ; rules <- mapM tcIfaceRule rules + + -- Exports + ; exports <- ifaceExportNames (mi_exports iface) -- Finished - ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules }) + ; return (ModDetails { md_types = type_env, + md_insts = dfuns, + md_rules = rules, + md_exports = exports }) } +\end{code} + + +%************************************************************************ +%* * + Type and class declarations +%* * +%************************************************************************ + +\begin{code} +tcHiBootIface :: 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 + = do { traceIf (text "loadHiBootInterface" <+> ppr mod) + + ; mode <- getGhciMode + ; if not (isOneShot mode) + -- In --make and interactive mode, if this module has an hs-boot file + -- we'll have compiled it already, and it'll be in the HPT + -- + -- We check wheher the interface is a *boot* interface. + -- It can happen (when using GHC from Visual Studio) that we + -- compile a module in TypecheckOnly mode, with a stable, + -- fully-populated HPT. In that case the boot interface isn't there + -- (it's been replaced by the mother module) so we can't check it. + -- 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 + Just info | mi_boot (hm_iface info) + -> return (hm_details info) + other -> return emptyModDetails } + else do + + -- OK, so we're in one-shot mode. + -- In that case, we're read all the direct imports by now, + -- 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 { + 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 + + do { read_result <- findAndReadIface + True -- Explicit import? + need mod + True -- Hi-boot file + + ; case read_result of + Failed err -> failWithTc (elaborate err) + Succeeded (iface, _path) -> typecheckIface iface + }}}} where - decls = map snd ver_decls + need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod + <+> ptext SLIT("to compare against the Real Thing") + + moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) + <+> ptext SLIT("depends on itself") + + elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+> + quotes (ppr mod) <> colon) 4 err \end{code} @@ -320,36 +344,24 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) ; info <- tcIdInfo name ty info ; return (AnId (mkVanillaGlobal name ty info)) } -tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name, - ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt, +tcIfaceDecl (IfaceData {ifName = occ_name, + ifTyVars = tv_bndrs, + ifCtxt = ctxt, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, ifGeneric = want_generic }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do - { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt) - - ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $ - tcIfaceCtxt rdr_ctxt - -- The reason for laziness here is to postpone - -- looking at the context, because the class may not - -- be in the type envt yet. E.g. - -- class Real a where { toRat :: a -> Ratio Integer } - -- data (Real a) => Ratio a = ... - -- We suck in the decl for Real, and type check it, which sucks - -- in the data type Ratio; but we must postpone typechecking the - -- context - - ; tycon <- fixM ( \ tycon -> do - { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons - ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons - arg_vrcs is_rec want_generic - ; return tycon + { tycon <- fixM ( \ tycon -> do + { stupid_theta <- tcIfaceCtxt ctxt + ; cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; buildAlgTyCon tc_name tyvars stupid_theta + cons arg_vrcs is_rec want_generic }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) - } } + }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) @@ -389,29 +401,54 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0 [])) } -tcIfaceDataCons tycon tyvars ctxt Unknown - = returnM Unknown - -tcIfaceDataCons tycon tyvars ctxt (DataCons cs) - = mappM tc_con_decl cs `thenM` \ data_cons -> - returnM (DataCons data_cons) +tcIfaceDataCons tycon tc_tyvars if_cons + = case if_cons of + IfAbstractTyCon -> return mkAbstractTyConRhs + 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) } where - tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls) - = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do - { name <- lookupIfaceTop occ - ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here + 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 + { name <- lookupIfaceTop occ + ; 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 + -- type and the classe: + -- E.g. + -- class Real a where { toRat :: a -> Ratio Integer } + -- data (Real a) => Ratio a = ... + -- But now I think that the laziness in checking class ops breaks + -- the loop, so no laziness needed -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ; + ; 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 stricts lbl_names - tyvars ctxt ex_tyvars ex_theta - arg_tys tycon + ; buildDataCon name False {- Not infix -} False {- Not vanilla -} + stricts [{- No fields -}] + con_tyvars theta + arg_tys tycon res_tys } - mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args] + mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name \end{code} @@ -421,119 +458,22 @@ tcIfaceDataCons tycon tyvars ctxt (DataCons cs) %* * %************************************************************************ -The gating story for instance declarations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are looking for a dict (C t1..tn), we slurp in instance decls for -C that - mention at least one of the type constructors - at the roots of t1..tn - -Why "at least one" rather than "all"? Because functional dependencies -complicate the picture. Consider - class C a b | a->b where ... - instance C Foo Baz where ... -Here, the gates are really only C and Foo, *not* Baz. -That is, if C and Foo are visible, even if Baz isn't, we must -slurp the decl, even if Baz is thus far completely unknown to the -system. - -Why "roots of the types"? Reason is overlap. For example, suppose there -are interfaces in the pool for - (a) C Int b - (b) C a [b] - (c) C a [T] -Then, if we are trying to resolve (C Int x), we need (a) -if we are trying to resolve (C x [y]), we need *both* (b) and (c), -even though T is not involved yet, so that we spot the overlap. - - -NOTE: if you use an instance decl with NO type constructors - instance C a where ... -and look up an Inst that only has type variables such as (C (n o)) -then GHC won't necessarily suck in the instances that overlap with this. - - \begin{code} -loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv -loadImportedInsts cls tys - = do { -- Get interfaces for wired-in things, such as Integer - -- Any non-wired-in tycons will already be loaded, else - -- we couldn't have them in the Type - ; this_mod <- getModule - ; let { (cls_gate, tc_gates) = predInstGates cls tys - ; imp_wi n = isWiredInName n && this_mod /= nameModule n - ; wired_tcs = filter imp_wi tc_gates } - -- Wired-in tycons not from this module. The "this-module" - -- test bites only when compiling Base etc, because loadHomeInterface - -- barfs if it's asked to load a non-existent interface - ; if null wired_tcs then returnM () - else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs) - - ; eps_var <- getEpsVar - ; eps <- readMutVar eps_var - - -- Suck in the instances - ; let { (inst_pool', iface_insts) - = WARN( null tc_gates, ptext SLIT("Interesting! No tycons in Inst:") - <+> pprClassPred cls tys ) - selectInsts (eps_insts eps) cls_gate tc_gates } - - -- Empty => finish up rapidly, without writing to eps - ; if null iface_insts then - return (eps_inst_env eps) - else do - { writeMutVar eps_var (eps {eps_insts = inst_pool'}) - - ; traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, - nest 2 (vcat (map ppr iface_insts))]) - - -- Typecheck the new instances - ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts) - - -- And put them in the package instance environment - ; updateEps ( \ eps -> - let - inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns - in - (eps { eps_inst_env = inst_env' }, inst_env') - )}} - where - wired_doc = ptext SLIT("Need home inteface for wired-in thing") - -tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst) - -tcIfaceInst :: IfaceInst -> IfL DFunId -tcIfaceInst (IfaceInst { ifDFun = dfun_occ }) - = tcIfaceExtId (LocalTop dfun_occ) - -selectInsts :: InstPool -> Name -> [Name] -> (InstPool, [(ModuleName, IfaceInst)]) -selectInsts pool@(Pool insts n_in n_out) cls tycons - = (Pool insts' n_in (n_out + length iface_insts), iface_insts) +tcIfaceInst :: IfaceInst -> IfL Instance +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 - (insts', iface_insts) - = case lookupNameEnv insts cls of { - Nothing -> (insts, []) ; - Just gated_insts -> - - case choose1 gated_insts of { - (_, []) -> (insts, []) ; -- None picked - (gated_insts', iface_insts') -> - - (extendNameEnv insts cls gated_insts', iface_insts') }} - - choose1 gated_insts - | null tycons -- Bizarre special case of C (a b); then there are no tycons - = ([], map snd gated_insts) -- Just grab all the instances, no real alternative - | otherwise -- Normal case - = foldl choose2 ([],[]) gated_insts - - -- Reverses the gated decls, but that doesn't matter - choose2 (gis, decls) (gates, decl) - | null gates -- Happens when we have 'instance T a where ...' - || any (`elem` tycons) gates = (gis, decl:decls) - | otherwise = ((gates,decl) : gis, decls) + do_tc Nothing = return Nothing + do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } \end{code} + %************************************************************************ %* * Rules @@ -545,63 +485,40 @@ 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} -loadImportedRules :: HscEnv -> ModGuts -> IO PackageRuleBase -loadImportedRules hsc_env guts - = initIfaceRules hsc_env guts $ do - { -- Get new rules - if_rules <- updateEps (\ eps -> - let { (new_pool, if_rules) = selectRules (eps_rules eps) (eps_PTE eps) } - in (eps { eps_rules = new_pool }, if_rules) ) - - ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules)) - - ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule) - ; core_rules <- mapM tc_rule if_rules - - -- Debug print - ; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules) - - -- Update the rule base and return it - ; updateEps (\ eps -> - let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules } - in (eps { eps_rule_base = new_rule_base }, new_rule_base) - ) - - -- Strictly speaking, at this point we should go round again, since - -- typechecking one set of rules may bring in new things which enable - -- some more rules to come in. But we call loadImportedRules several - -- times anyway, so I'm going to be lazy and ignore this. - } - - -selectRules :: RulePool -> TypeEnv -> (RulePool, [(ModuleName, IfaceRule)]) --- Not terribly efficient. Look at each rule in the pool to see if --- all its gates are in the type env. If so, take it out of the pool. --- If not, trim its gates for next time. -selectRules (Pool rules n_in n_out) type_env - = (Pool rules' n_in (n_out + length if_rules), 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') <- + -- 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, + ru_bndrs = bndrs', ru_args = args', + ru_rhs = rhs', ru_orph = orph, + ru_rough = mb_tcs, + ru_local = isLocalIfaceExtName fn }) } where - (rules', if_rules) = foldl do_one ([], []) rules - - do_one (pool, if_rules) (gates, rule) - | null gates' = (pool, rule:if_rules) - | otherwise = ((gates',rule) : pool, if_rules) - where - gates' = filter (not . (`elemNameEnv` type_env)) gates - - -tcIfaceRule :: IfaceRule -> IfL IdCoreRule -tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs }) - = bindIfaceBndrs bndrs $ \ bndrs' -> - do { fn <- tcIfaceExtId fn_rdr - ; args' <- mappM tcIfaceExpr args - ; rhs' <- tcIfaceExpr rhs - ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) } - -tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule) - = do { fn <- tcIfaceExtId fn_rdr - ; returnM (fn, core_rule) } + -- This function *must* mirror exactly what Rules.topFreeName does + -- We could have stored the ru_rough field in the iface file + -- but that would be redundant, I think. + -- The only wrinkle is that we must not be deceived by + -- 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 \end{code} @@ -616,7 +533,7 @@ tcIfaceType :: IfaceType -> IfL Type tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } -tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') } +tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') } @@ -683,7 +600,7 @@ tcIfaceExpr (IfaceApp fun arg) tcIfaceExpr arg `thenM` \ arg' -> returnM (App fun' arg') -tcIfaceExpr (IfaceCase scrut case_bndr alts) +tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = tcIfaceExpr scrut `thenM` \ scrut' -> newIfaceName case_bndr `thenM` \ case_bndr_name -> let @@ -698,7 +615,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) in extendIfaceIdEnv [case_bndr'] $ mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - returnM (Case scrut' case_bndr' alts') + tcIfaceType ty `thenM` \ ty' -> + returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = tcIfaceExpr rhs `thenM` \ rhs' -> @@ -740,63 +658,60 @@ 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_occs, rhs) - = let - tycon_mod = nameModuleName (tyConName tycon) - in - tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con -> - newIfaceNames arg_occs `thenM` \ arg_names -> - let - ex_tyvars = dataConExistentialTyVars con - main_tyvars = tyConTyVars tycon - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = dropList ex_tyvars arg_names - arg_ids -#ifdef DEBUG - | not (equalLength id_names arg_tys) - = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$ - (ppr main_tyvars <+> ppr ex_tyvars) $$ - ppr arg_tys) - | otherwise -#endif - = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys - in - ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars, - ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars ) - extendIfaceTyVarEnv ex_tyvars' $ - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, ex_tyvars' ++ arg_ids, 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 + 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 + + ; rhs' <- extendIfaceTyVarEnv tyvars $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) - = newIfaceNames arg_occs `thenM` \ arg_names -> - let - [con] = tyConDataCons tycon - arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys - in - ASSERT( isTupleTyCon tycon ) - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, arg_ids, 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') } \end{code} \begin{code} -tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core -tcExtCoreBindings mod [] = return [] -tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs) +tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core +tcExtCoreBindings [] = return [] +tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs) -do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] -do_one mod (IfaceNonRec bndr rhs) thing_inside +do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] +do_one (IfaceNonRec bndr rhs) thing_inside = do { rhs' <- tcIfaceExpr rhs - ; bndr' <- newExtCoreBndr mod bndr + ; bndr' <- newExtCoreBndr bndr ; extendIfaceIdEnv [bndr'] $ do { core_binds <- thing_inside ; return (NonRec bndr' rhs' : core_binds) }} -do_one mod (IfaceRec pairs) thing_inside - = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs +do_one (IfaceRec pairs) thing_inside + = do { bndrs' <- mappM newExtCoreBndr bndrs ; extendIfaceIdEnv bndrs' $ do { rhss' <- mappM tcIfaceExpr rhss ; core_binds <- thing_inside @@ -813,10 +728,9 @@ do_one mod (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} -tcIdInfo name ty NoInfo = return vanillaIdInfo -tcIdInfo name ty DiscardedInfo = return vanillaIdInfo -tcIdInfo name ty (HasInfo iface_info) - = foldlM tcPrag init_info iface_info +tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo +tcIdInfo name ty NoInfo = return vanillaIdInfo +tcIdInfo name ty (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 @@ -842,8 +756,8 @@ tcIdInfo name ty (HasInfo iface_info) \end{code} \begin{code} -tcWorkerInfo ty info wkr_name arity - = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId (LocalTop wkr_name)) +tcWorkerInfo ty info wkr arity + = 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 @@ -856,7 +770,7 @@ tcWorkerInfo ty info wkr_name arity Nothing -> info Just wkr_id -> add_wkr_info us wkr_id info) } where - doc = text "Worker for" <+> ppr wkr_name + 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 @@ -867,7 +781,7 @@ tcWorkerInfo ty info wkr_name arity -- before worker info, fingers crossed .... strict_sig = case newStrictnessInfo info of Just sig -> sig - Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name) + Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr) \end{code} For unfoldings we try to do the job lazily, so that we never type check @@ -904,6 +818,92 @@ tcPragExpr name expr %************************************************************************ %* * + Getting from Names to TyThings +%* * +%************************************************************************ + +\begin{code} +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 + | 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 { + Just (mod, get_type_env) + | nameIsLocalOrFrom mod name + -> do -- It's defined in the module being compiled + { type_env <- setLclEnv () get_type_env -- yuk + ; case lookupNameEnv type_env name of + Just thing -> return thing + Nothing -> pprPanic "tcIfaceGlobal (local): not found:" + (ppr name $$ ppr type_env) } + + ; other -> do + + { mb_thing <- importDecl name -- It's imported; go get it + ; case mb_thing of + Failed err -> failIfM err + Succeeded thing -> return thing + }}}}} + +tcIfaceTyCon :: IfaceTyCon -> IfL TyCon +tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon +tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon +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 + ; return (check_tc (tyThingTyCon thing)) } + where +#ifdef DEBUG + check_tc tc = case toIfaceTyCon (error "urk") tc of + IfaceTc _ -> tc + other -> pprTrace "check_tc" (ppr tc) tc +#else + check_tc tc = tc +#endif + +-- 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) + ; return tc } + +tcIfaceClass :: IfaceExtName -> IfL Class +tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name + ; thing <- tcIfaceGlobal name + ; return (tyThingClass thing) } + +tcIfaceDataCon :: IfaceExtName -> IfL DataCon +tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl + ; thing <- tcIfaceGlobal name + ; case thing of + ADataCon dc -> return dc + other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) } + +tcIfaceExtId :: IfaceExtName -> IfL Id +tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl + ; thing <- tcIfaceGlobal name + ; case thing of + AnId id -> return id + other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) } +\end{code} + +%************************************************************************ +%* * Bindings %* * %************************************************************************ @@ -941,9 +941,10 @@ bindIfaceIds bndrs thing_inside ----------------------- -newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id -newExtCoreBndr mod (occ, ty) - = do { name <- newGlobalBinder mod occ Nothing noSrcLoc +newExtCoreBndr :: (OccName, IfaceType) -> IfL Id +newExtCoreBndr (occ, ty) + = do { mod <- getIfModule + ; name <- newGlobalBinder mod occ Nothing noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } @@ -964,3 +965,4 @@ bindIfaceTyVars bndrs thing_inside mk_iface_tyvar name kind = mkTyVar name kind \end{code} +