X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=39eadfb681b61453db59be4dc4970b66f2d2b797;hb=9d458d01d2a75b1e452ba00c4e76f3c3d0bc5ba6;hp=911f4b1c84829a360b9dacb085a4b835e657c47c;hpb=576650d4966549866ad2d07d618f99c9a0c7529d;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 911f4b1..39eadfb 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -6,7 +6,7 @@ \begin{code} module TcIface ( tcImportDecl, typecheckIface, - tcIfaceKind, loadImportedInsts, + tcIfaceKind, loadImportedInsts, loadImportedRules, tcExtCoreBindings ) where #include "HsVersions.h" @@ -22,16 +22,17 @@ import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass ) import TcRnMonad import Type ( Kind, openTypeKind, liftedTypeKind, unliftedTypeKind, mkArrowKind, splitTyConApp, - mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType ) + mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred ) import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) -import HscTypes ( ExternalPackageState(..), PackageInstEnv, - TyThing(..), implicitTyThings, - ModIface(..), ModDetails(..), InstPool, +import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase, + HscEnv, TyThing(..), implicitTyThings, typeEnvIds, + ModIface(..), ModDetails(..), InstPool, ModGuts, TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv, - DeclPool, RulePool, Pool(..), Gated, addRuleToPool ) + RulePool, Pool(..) ) import InstEnv ( extendInstEnv ) import CoreSyn +import PprCore ( pprIdRules ) import Rules ( extendRuleBaseList ) import CoreUtils ( exprType ) import CoreUnfold @@ -57,7 +58,7 @@ import Module ( Module, ModuleName, moduleName ) import UniqSupply ( initUs_ ) import Outputable import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual, dropList, equalLength ) +import Util ( zipWithEqual, dropList, equalLength, zipLazy ) import Maybes ( expectJust ) import CmdLineOpts ( DynFlag(..) ) \end{code} @@ -112,12 +113,12 @@ tcImportDecl name = do { -- Make sure the interface is loaded ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name } - ; traceIf nd_doc + ; 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-commital 'Nothing' in - -- the namePareent field (made up by IfaceEnv.lookupOrig), but + -- 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) @@ -132,7 +133,7 @@ tcImportDecl name ; 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) + ; traceIf (ptext SLIT(" ...imported decl for") <+> ppr main_thing <+> extra <+> char '}') -- Look up the wanted Name in the type envt; it might be @@ -152,7 +153,7 @@ recordImportOf :: TyThing -> IfG () -- whose gates are all in the type envt, is in eps_rule_base recordImportOf thing - = do { (new_things, iface_rules) <- updateEps (\ eps -> + = 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! @@ -163,23 +164,12 @@ recordImportOf thing -- * which pokes the suspended forks -- * which, to execute, need to consult type-env (to check -- entirely unrelated types, perhaps) - - ; (new_rules, iface_rules) = selectRules (eps_rules eps) - (map getName new_things) - new_type_env } - in (eps { eps_PTE = new_type_env, eps_rules = new_rules }, - (new_things, iface_rules)) + } + in (eps { eps_PTE = new_type_env }, new_things) ) - - -- Now type-check those rules (which may side-effect the EPS again) ; traceIf (text "tcImport: extend type env" <+> ppr new_things) - ; core_rules <- mapM tc_rule iface_rules - ; updateEps_ (\ eps -> - eps { eps_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules } - ) } + } -tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule) - 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) @@ -191,49 +181,83 @@ getThing name | otherwise = do -- The normal case, not wired in { -- Get the decl from the pool - decl <- updateEps (\ eps -> - let - (decls', decl) = selectDecl (eps_decls eps) name - in - (eps { eps_decls = decls' }, decl)) - - -- Typecheck it - -- Side-effects EPS by faulting in any needed decls - -- (via nested calls to tcImportDecl) - ; initIfaceLcl (nameModuleName name) (tcIfaceDecl decl) } - + 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 + + } + 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 :: DeclPool -> Name -> (DeclPool, IfaceDecl) +selectDecl :: ExternalPackageState -> Name -> (ExternalPackageState, Maybe IfaceDecl) -- Use nameParent to get the parent name of the thing -selectDecl (Pool decls_map n_in n_out) name - = (Pool decls' n_in (n_out+1), decl) +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 - decl = case lookupNameEnv decls_map main_name of - Nothing -> pprPanic "selectDecl" (ppr main_name <+> ppr name) ; - Just decl -> decl - - decls' = delFromNameEnv decls_map main_name + decls' = delFromNameEnv decls_map main_name \end{code} %************************************************************************ %* * - Other interfaces + Type-checking a complete interface %* * %************************************************************************ +Suppose we discover we don't need to recompile. Then we must type +check the old interface file. This is a bit different to the +incremental type checking we do as we suck in interface files. Instead +we do things similarly as when we are typechecking source decls: we +bring into scope the type envt for the interface all at once, using a +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 :: ModIface -> IfG ModDetails --- Used when we decide not to recompile, but intead to use the --- interface to construct the type environment for the module -typecheckIface iface - = initIfaceLcl (moduleName (mi_module iface)) $ - do { ty_things <- mapM (tcIfaceDecl . snd) (mi_decls iface) - ; rules <- mapM tcIfaceRule (mi_rules iface) +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) } + ; writeMutVar tc_env_var type_env + + -- Now do those rules and instances ; dfuns <- mapM tcIfaceInst (mi_insts iface) - ; return (ModDetails { md_types = mkTypeEnv ty_things, - md_insts = dfuns, - md_rules = rules }) } + ; rules <- mapM tcIfaceRule (mi_rules iface) + + -- Finished + ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules }) + } + where + decls = map snd ver_decls \end{code} @@ -422,6 +446,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 @@ -443,11 +474,9 @@ loadImportedInsts cls tys -- Suck in the instances ; let { (inst_pool', iface_insts) - = selectInsts (eps_insts eps) cls_gate tc_gates } - - ; traceTc (text "loadImportedInsts" <+> vcat [ppr cls <+> ppr tys, - text "new pool" <+> ppr inst_pool', - text "new insts" <+> ppr 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 @@ -455,6 +484,9 @@ loadImportedInsts cls tys 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) @@ -481,18 +513,25 @@ selectInsts pool@(Pool insts n_in n_out) cls tycons (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} %************************************************************************ @@ -506,30 +545,50 @@ 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} -selectRules :: RulePool - -> [Name] -- Names of things being added - -> TypeEnv -- New type env, including things being added - -> (RulePool, [(ModuleName, IfaceRule)]) -selectRules (Pool rules n_in n_out) new_names type_env - = (Pool rules' n_in (n_out + length iface_rules), iface_rules) +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) where - (rules', iface_rules) = foldl select_one (rules, []) new_names - - select_one :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Name - -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) - select_one (rules, decls) name - = case lookupNameEnv rules name of - Nothing -> (rules, decls) - Just gated_rules -> foldl filter_rule (delFromNameEnv rules name, decls) gated_rules - - filter_rule :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Gated IfaceRule - -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) - filter_rule (rules, decls) (rule_fvs, rule) - = case [fv | fv <- rule_fvs, not (fv `elemNameEnv` type_env)] of - [] -> -- No remaining FVs, so slurp it - (rules, rule:decls) - fvs -> -- There leftover fvs, so toss it back in the pool - (addRuleToPool rules rule fvs, decls) + (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, @@ -829,7 +888,8 @@ tcPragExpr name expr -- Check for type consistency in the unfolding ifOptM Opt_DoCoreLinting ( - case lintUnfolding noSrcLoc [{- in scope -}] core_expr' of + get_in_scope_ids `thenM` \ in_scope -> + case lintUnfolding noSrcLoc in_scope core_expr' of Nothing -> returnM () Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg) ) `thenM_` @@ -837,6 +897,14 @@ tcPragExpr name expr returnM core_expr' where doc = text "Unfolding of" <+> ppr name + get_in_scope_ids -- Urgh; but just for linting + = setLclEnv () $ + do { env <- getGblEnv + ; case if_rec_types env of { + Nothing -> return [] ; + Just (_, get_env) -> do + { type_env <- get_env + ; return (typeEnvIds type_env) }}} \end{code}