X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=a75582aa515ebf78b167e46bb707303dd7aeb517;hb=a84285247bfb162fdefc3fcb8be88c34c1f5cd35;hp=c8c27e936378d99be96c61e4b5f5dd86312144d0;hpb=57573e7e61032482d6be16ed4ac86c2b4115fbfa;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index c8c27e9..a75582a 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -5,32 +5,33 @@ \begin{code} module TcIface ( - tcImportDecl, typecheckIface, - tcIfaceKind, loadImportedInsts, loadImportedRules, + 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, loadInterface, predInstGates, + loadDecls ) +import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, 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 ( Kind, openTypeKind, liftedTypeKind, - unliftedTypeKind, mkArrowKind, splitTyConApp, - mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred ) +import TcType ( hoistForAllTys ) -- TEMPORARY HACK +import Type ( liftedTypeKind, splitTyConApp, mkSynTy, mkTyConApp, + mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred ) 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, - DeclPool, RulePool, Pool(..), Gated, addRuleToPool ) -import InstEnv ( extendInstEnv ) +import TyCon ( TyCon, tyConName, isSynTyCon ) +import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, + HscEnv, TyThing(..), tyThingClass, tyThingTyCon, + ModIface(..), ModDetails(..), ModGuts, + extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds ) +import InstEnv ( extendInstEnvList ) import CoreSyn import PprCore ( pprIdRules ) import Rules ( extendRuleBaseList ) @@ -46,20 +47,21 @@ 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, dataConArgTys, isVanillaDataCon ) +import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, +import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) -import Module ( Module, ModuleName, moduleName ) +import Module ( Module ) import UniqSupply ( initUs_ ) import Outputable +import ErrUtils ( Message ) +import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, dropList, equalLength, zipLazy ) -import Maybes ( expectJust ) +import Util ( zipWithEqual, dropList, equalLength ) import CmdLineOpts ( DynFlag(..) ) \end{code} @@ -107,109 +109,47 @@ 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 +tcImportDecl :: Name -> TcM TyThing +-- Entry point for source-code uses of importDecl +tcImportDecl name + = do { traceIf (text "tcLookupGlobal" <+> ppr name) + ; mb_thing <- initIfaceTcRn (importDecl name) + ; case mb_thing of + Succeeded thing -> return thing + Failed err -> failWithTc err } + +importDecl :: Name -> IfM lcl (MaybeErr Message 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 +importDecl 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 definitely happens for tuples, because we + -- don't know how many of them we'll find + -- It also now happens for all other wired in things. We used + -- to pre-populate the eps_PTE with other wired-in things, but + -- we don't seem to do that any more. I guess it keeps the PTE smaller? + = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing }) + ; return (Succeeded thing) } + + | otherwise + = 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} %************************************************************************ @@ -230,34 +170,32 @@ 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 - ; 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) } + { -- 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 -- Finished ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules }) } - where - decls = map snd ver_decls \end{code} @@ -320,36 +258,23 @@ 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, 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 + { tycon <- fixM ( \ tycon -> do + { cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; tycon <- buildAlgTyCon tc_name tyvars cons arg_vrcs is_rec want_generic ; return tycon }) ; 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 +314,58 @@ 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 mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt + ; data_cons <- mappM tc_con_decl cons + ; return (mkDataTyConRhs mb_theta 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_ctxt Nothing = return Nothing + tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) } + + 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) ; - - ; lbl_names <- mappM lookupIfaceTop field_lbls + ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) + ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress) - ; 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} @@ -446,6 +400,13 @@ 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 @@ -462,21 +423,15 @@ loadImportedInsts cls tys ; 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) - = 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, - nest 2 (vcat (map ppr iface_insts))]) + { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, + nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])]) -- Typecheck the new instances ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts) @@ -484,38 +439,52 @@ loadImportedInsts cls tys -- And put them in the package instance environment ; updateEps ( \ eps -> let - inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns + inst_env' = extendInstEnvList (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) +tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst) + where + full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr 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) +selectInsts :: Name -> [Name] -> ExternalPackageState + -> (ExternalPackageState, [(Module, SDoc, 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, []) ; - Just gated_insts -> + Just gated_insts -> - case foldl choose ([],[]) gated_insts of { + 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 - choose (gis, decls) (gates, decl) - | any (`elem` tycons) gates = (gis, decl:decls) - | otherwise = ((gates,decl) : gis, decls) + 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) \end{code} %************************************************************************ @@ -529,17 +498,15 @@ 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)) + ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules]) - ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule) ; core_rules <- mapM tc_rule if_rules -- Debug print @@ -555,23 +522,32 @@ 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)]) +tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule) + where + full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule)) + +selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, 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) | null gates' = (pool, rule:if_rules) | otherwise = ((gates',rule) : pool, if_rules) where - gates' = filter (`elemNameEnv` type_env) gates + gates' = filter (not . (`elemNameEnv` type_env)) gates tcIfaceRule :: IfaceRule -> IfL IdCoreRule @@ -581,11 +557,18 @@ tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs do { fn <- tcIfaceExtId fn_rdr ; args' <- mappM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs - ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) } + ; let rule = Rule rule_name act bndrs' args' rhs' + ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) } + where tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule) = do { fn <- tcIfaceExtId fn_rdr - ; returnM (fn, core_rule) } + ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) } + +isOrphNm :: IfaceExtName -> Bool +-- An orphan name comes from somewhere other than this module, +-- so it has a non-local name +isOrphNm name = not (isLocalIfaceExtName name) \end{code} @@ -596,23 +579,25 @@ tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule) %************************************************************************ \begin{code} -tcIfaceKind :: IfaceKind -> Kind -tcIfaceKind IfaceOpenTypeKind = openTypeKind -tcIfaceKind IfaceLiftedTypeKind = liftedTypeKind -tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind -tcIfaceKind (IfaceFunKind k1 k2) = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2) - ------------------------------------------ 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 (mkIfTcApp 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') } tcIfaceTypes tys = mapM tcIfaceType tys +mkIfTcApp :: TyCon -> [Type] -> Type +-- In interface files we retain type synonyms (for brevity and better error +-- messages), but type synonyms can expand into non-hoisted types (ones with +-- foralls to the right of an arrow), so we must be careful to hoist them here. +-- This hack should go away when we get rid of hoisting. +mkIfTcApp tc tys + | isSynTyCon tc = hoistForAllTys (mkSynTy tc tys) + | otherwise = mkTyConApp tc tys + ----------------------------------------- tcIfacePredType :: IfacePredType -> IfL PredType tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } @@ -674,7 +659,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 @@ -689,7 +674,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' -> @@ -731,63 +717,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 = dataConArgTys 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 = dataConArgTys 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 @@ -804,10 +787,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 @@ -833,8 +815,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 @@ -847,7 +829,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 @@ -858,7 +840,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 @@ -895,6 +877,70 @@ tcPragExpr name expr %************************************************************************ %* * + Getting from Names to TyThings +%* * +%************************************************************************ + +\begin{code} +tcIfaceGlobal :: Name -> IfL TyThing +tcIfaceGlobal name + = 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 = 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 %* * %************************************************************************ @@ -932,9 +978,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') } @@ -953,5 +1000,6 @@ bindIfaceTyVars bndrs thing_inside where (occs,kinds) = unzip bndrs -mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind) +mk_iface_tyvar name kind = mkTyVar name kind \end{code} +