X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FTcIface.lhs;h=39eadfb681b61453db59be4dc4970b66f2d2b797;hb=9d458d01d2a75b1e452ba00c4e76f3c3d0bc5ba6;hp=dce075c435669c31973b957eb518aa5008e894b4;hpb=7e7c11b2b285fd00758baac1be3784322a2aff62;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index dce075c..39eadfb 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -22,14 +22,14 @@ 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, 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 ) @@ -58,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} @@ -181,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} @@ -412,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 @@ -433,7 +474,9 @@ loadImportedInsts cls tys -- Suck in the instances ; let { (inst_pool', iface_insts) - = selectInsts (eps_insts eps) cls_gate tc_gates } + = 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 @@ -441,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) @@ -467,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} %************************************************************************ @@ -534,7 +587,7 @@ selectRules (Pool rules n_in n_out) type_env | 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