X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=1d08095f264ae9e705041d09dc79e96ff26bffe9;hb=9eb6cb808766126461564120923eb5d983221843;hp=244c919c5910d42e4fe0fe8a71dbc36b60b6bf77;hpb=3cc0dcd426c329b84742676f85d50a059da24267;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 244c919..1d08095 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -5,30 +5,31 @@ \begin{code} module TcIface ( - tcImportDecl, typecheckIface, + tcImportDecl, typecheckIface, tcIfaceDecl, tcIfaceGlobal, loadImportedInsts, loadImportedRules, tcExtCoreBindings ) where #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadHomeInterface, predInstGates ) -import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig, +import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags ) +import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId, - tcIfaceDataCon, tcIfaceLclId, + tcIfaceTyVar, tcIfaceLclId, newIfaceName, newIfaceNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass ) +import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, + mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred ) import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) -import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase, - HscEnv, TyThing(..), implicitTyThings, typeEnvIds, +import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, + HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), InstPool, ModGuts, - TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv, - RulePool, Pool(..) ) + TypeEnv, mkTypeEnv, extendTypeEnv, extendTypeEnvList, + lookupTypeEnv, lookupType, typeEnvIds, + RulePool ) import InstEnv ( extendInstEnv ) import CoreSyn import PprCore ( pprIdRules ) @@ -45,11 +46,12 @@ 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, tyConTyVars, isTupleTyCon, mkForeignTyCon ) +import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) +import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon, + tupleTyCon, tupleCon ) import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, +import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, nameIsLocalOrFrom, isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe ) import NameEnv import OccName ( OccName ) @@ -59,7 +61,10 @@ import Outputable import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, dropList, equalLength, zipLazy ) import Maybes ( expectJust ) -import CmdLineOpts ( DynFlag(..), dopt ) +import CmdLineOpts ( DynFlag(..) ) + +import UniqFM (sizeUFM) + \end{code} This module takes @@ -109,122 +114,33 @@ also turn out to be needed by the code that e2 expands to. 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) - } - -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" - -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 - + -- This case only happens for tuples, because we pre-populate the eps_PTE + -- with other wired-in things. We can't do that for tuples because we + -- don't know how many of them we'll find + = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing }) + ; return thing } + + | otherwise + = do { traceIf nd_doc + + -- Load the interface, which should populate the PTE + ; loadHomeInterface nd_doc name + + -- Now look it up again; this time we should find it + ; eps <- getEps + ; case lookupTypeEnv (eps_PTE eps) name of + Just thing -> return thing + 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 } 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"), + nd_doc = ptext SLIT("Need decl for") <+> ppr name + 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 name of { - -- This first lookup will usually fail for subordinate names, because - -- the relevant decl is the parent decl. - -- But, if we export a data type decl abstractly, its selectors - -- get separate type signatures in the interface file - Just decl -> let - decls' = delFromNameEnv decls_map name - in - (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ; - - Nothing -> - case nameParent_maybe name of { - Nothing -> (eps, Nothing ) ; -- No "parent" - Just main_name -> -- Has a parent; try that - - case lookupNameEnv decls_map main_name of { - Just decl -> let - decls' = delFromNameEnv decls_map main_name - in - (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ; - Nothing -> (eps, Nothing) - }}} \end{code} %************************************************************************ @@ -245,11 +161,23 @@ and even if they were, the type decls might be mutually recursive. 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 }) +typecheckIface hsc_env iface = initIfaceTc hsc_env iface $ \ tc_env_var -> do - { -- Typecheck the decls - names <- mappM (lookupOrig (moduleName mod) . ifName) decls + { -- 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 + ; let { decls | ignore_prags = map (discardDeclPrags . snd) (mi_decls iface) + | otherwise = map snd (mi_decls iface) + ; rules | ignore_prags = [] + | otherwise = mi_rules iface + ; dfuns = mi_insts iface + ; mod_name = moduleName (mi_module iface) + } + -- Typecheck the decls + ; names <- mappM (lookupOrig mod_name . 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, @@ -265,14 +193,12 @@ typecheckIface hsc_env iface@(ModIface { mi_module = mod, mi_decls = ver_decls, ; writeMutVar tc_env_var type_env -- Now do those rules and instances - ; dfuns <- mapM tcIfaceInst (mi_insts iface) - ; rules <- mapM tcIfaceRule (mi_rules iface) + ; dfuns <- mapM tcIfaceInst dfuns + ; rules <- mapM tcIfaceRule rules -- Finished ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules }) } - where - decls = map snd ver_decls \end{code} @@ -335,7 +261,7 @@ 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, +tcIfaceDecl (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, @@ -358,7 +284,7 @@ tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name, ; tycon <- fixM ( \ tycon -> do { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons - ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons + ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons arg_vrcs is_rec want_generic ; return tycon }) @@ -404,14 +330,15 @@ 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 tyvars ctxt 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 data_con) } where - tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls) + tc_con_decl (IfaceConDecl occ is_infix 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 @@ -422,7 +349,7 @@ tcIfaceDataCons tycon tyvars ctxt (DataCons cs) ; lbl_names <- mappM lookupIfaceTop field_lbls - ; buildDataCon name stricts lbl_names + ; buildDataCon name is_infix stricts lbl_names tyvars ctxt ex_tyvars ex_theta arg_tys tycon } @@ -484,33 +411,14 @@ loadImportedInsts cls tys ; if null wired_tcs then returnM () else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs) - ; eps_var <- getEpsVar - ; eps <- readMutVar eps_var - - -- For interest: report the no-type-constructor case. - -- Don't report when -fallow-undecidable-instances is on, because then - -- we call loadImportedInsts when looking up even predicates like (C a) - -- But without undecidable instances it's rare to see C (a b) and - -- somethat interesting -#ifdef DEBUG - ; dflags <- getDOpts - ; WARN( not (dopt Opt_AllowUndecidableInstances dflags) && null tc_gates, - ptext SLIT("Interesting! No tycons in Inst:") - <+> pprClassPred cls tys ) - return () -#endif - - -- Suck in the instances - ; let { (inst_pool', iface_insts) - = selectInsts (eps_insts eps) cls_gate tc_gates } + -- Now suck in the relevant instances + ; iface_insts <- updateEps (selectInsts cls_gate tc_gates) -- Empty => finish up rapidly, without writing to eps ; if null iface_insts then - return (eps_inst_env eps) + do { eps <- getEps; 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, + { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, nest 2 (vcat (map ppr iface_insts))]) -- Typecheck the new instances @@ -532,10 +440,14 @@ 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) +selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceInst)]) +selectInsts cls tycons eps + = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts) where + insts = eps_insts eps + stats = eps_stats eps + stats' = stats { n_insts_out = n_insts_out stats + length iface_insts } + (insts', iface_insts) = case lookupNameEnv insts cls of { Nothing -> (insts, []) ; @@ -571,13 +483,12 @@ 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 :: HscEnv -> ModGuts -> IO [IdCoreRule] +-- Returns just the new rules added 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) ) + if_rules <- updateEps selectRules ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules)) @@ -597,16 +508,22 @@ loadImportedRules hsc_env guts -- 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. + ; return core_rules } -selectRules :: RulePool -> TypeEnv -> (RulePool, [(ModuleName, IfaceRule)]) +selectRules :: ExternalPackageState -> (ExternalPackageState, [(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) +selectRules eps + = (eps { eps_rules = rules', eps_stats = stats' }, if_rules) where + stats = eps_stats eps + rules = eps_rules eps + type_env = eps_PTE eps + stats' = stats { n_rules_out = n_rules_out stats + length if_rules } + (rules', if_rules) = foldl do_one ([], []) rules do_one (pool, if_rules) (gates, rule) @@ -839,10 +756,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 @@ -868,8 +784,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 @@ -882,7 +798,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 @@ -893,7 +809,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 @@ -930,6 +846,67 @@ tcPragExpr name expr %************************************************************************ %* * + Getting from Names to TyThings +%* * +%************************************************************************ + +\begin{code} +tcIfaceGlobal :: Name -> IfM a TyThing +tcIfaceGlobal name + = do { (eps,hpt) <- getEpsAndHpt + ; case lookupType hpt (eps_PTE eps) name of { + Just thing -> return thing ; + Nothing -> + + setLclEnv () $ do -- This gets us back to IfG, mainly to + -- pacify get_type_env; rather untidy + { 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 <- get_type_env + ; case lookupNameEnv type_env name of + Just thing -> return thing + Nothing -> pprPanic "tcIfaceGlobal (local): not found:" + (ppr name $$ ppr type_env) } + + other -> tcImportDecl name -- It's imported; go get it + }}} + +tcIfaceTyCon :: IfaceTyCon -> IfL TyCon +tcIfaceTyCon IfaceIntTc = return intTyCon +tcIfaceTyCon IfaceBoolTc = return boolTyCon +tcIfaceTyCon IfaceCharTc = return charTyCon +tcIfaceTyCon IfaceListTc = return listTyCon +tcIfaceTyCon IfacePArrTc = return parrTyCon +tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar) +tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm + ; thing <- tcIfaceGlobal name + ; return (tyThingTyCon thing) } + +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 %* * %************************************************************************ @@ -990,3 +967,4 @@ bindIfaceTyVars bndrs thing_inside mk_iface_tyvar name kind = mkTyVar name kind \end{code} +