From: simonpj Date: Thu, 16 Oct 2003 10:19:28 +0000 (+0000) Subject: [project @ 2003-10-16 10:19:27 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~360 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1c9f0be145ee4153d9dc88ad8afd784912a6b271;p=ghc-hetmet.git [project @ 2003-10-16 10:19:27 by simonpj] When type-checking an interface in --make, when the source file hasn't changed, we must bring into scope all the things defined in the interface. This was breaking --make badly. The epicentre here is TcIface.typecheckIface --- diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 0141f77..60c2ecb 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -296,7 +296,7 @@ tcIfaceGlobal name }}} tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon IfaceIntTc = return intTyCon +tcIfaceTyCon IfaceIntTc = return intTyCon tcIfaceTyCon IfaceBoolTc = return boolTyCon tcIfaceTyCon IfaceCharTc = return charTyCon tcIfaceTyCon IfaceListTc = return listTyCon @@ -362,24 +362,6 @@ extendIfaceTyVarEnv tyvars thing_inside %* * %************************************************************************ -IfaceDecls etc are populated with RdrNames. The RdrNames may either be - - Orig or Unqual when the interface is read from a file - - Exact when the interface is kept by GHCi, and is now - being re-linked with the type environment - -At an occurrence site, to convert the RdrName to Name: - Unqual look up in LocalRdrEnv - Orig look up in OrigNameCache - Exact return the Name - -At a binding site, to bind the RdrName - Unqual we extend the LocalRdrEnv - Orig or Unqual we don't extend the LocalRdrEnv (no need) - -First, we deal with the RdrName -> Name mapping - \begin{code} lookupIfaceTc :: IfaceTyCon -> IfL Name lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index dce075c..73f20cd 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -32,6 +32,7 @@ import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase, DeclPool, RulePool, Pool(..), Gated, addRuleToPool ) import InstEnv ( extendInstEnv ) import CoreSyn +import PprType ( pprClassPred ) import PprCore ( pprIdRules ) import Rules ( extendRuleBaseList ) import CoreUtils ( exprType ) @@ -58,7 +59,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} @@ -208,22 +209,50 @@ selectDecl (Pool decls_map n_in n_out) name %************************************************************************ %* * - 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} @@ -441,6 +470,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) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 4de831c..9ce0bb7 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -42,7 +42,8 @@ import StringBuffer ( hGetStringBuffer ) import Parser import Lexer ( P(..), ParseResult(..), mkPState, showPFailed ) import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( tcRnModule, tcRnExtCore, tcRnIface ) +import TcRnDriver ( tcRnModule, tcRnExtCore ) +import TcIface ( typecheckIface ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) @@ -182,7 +183,7 @@ hscNoRecomp hsc_env have_object showModMsg have_object mod location); new_details <- _scc_ "tcRnIface" - tcRnIface hsc_env old_iface ; + typecheckIface hsc_env old_iface ; dumpIfaceStats hsc_env ; return (HscNoRecomp new_details old_iface) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 9a9e98b..b1dd133 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -10,7 +10,7 @@ module TcRnDriver ( #endif tcRnModule, tcTopSrcDecls, - tcRnIface, tcRnExtCore + tcRnExtCore ) where #include "HsVersions.h" @@ -42,7 +42,7 @@ import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( typecheckIface, tcExtCoreBindings ) +import TcIface ( tcExtCoreBindings ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) @@ -199,24 +199,6 @@ tcRnModule hsc_env \end{code} -%********************************************************* -%* * -\subsection{Closing up the interface decls} -%* * -%********************************************************* - -Suppose we discover we don't need to recompile. Then we start from the -IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need. - -\begin{code} -tcRnIface :: HscEnv - -> ModIface -- Get the decls from here - -> IO ModDetails -tcRnIface hsc_env iface - = initIfaceTc hsc_env iface (typecheckIface iface) -\end{code} - - %************************************************************************ %* * The interactive interface diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index b3bd086..4d2e8bf 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -12,7 +12,7 @@ import IOEnv -- Re-export all import HsSyn ( MonoBinds(..) ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, Dependencies(..), + TyThing, Dependencies(..), TypeEnv, emptyTypeEnv, ExternalPackageState(..), HomePackageTable, ModDetails(..), HomeModInfo(..), Deprecs(..), FixityEnv, FixItem, @@ -754,15 +754,22 @@ initIfaceCheck hsc_env do_this ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceTc :: HscEnv -> ModIface -> IfG a -> IO a +initIfaceTc :: HscEnv -> ModIface + -> (TcRef TypeEnv -> IfL a) -> IO a -- Used when type-checking checking an up-to-date interface file -- No type envt from the current module, but we do know the module dependencies initIfaceTc hsc_env iface do_this - = do { let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)), - if_rec_types = Nothing } ; + = do { tc_env_var <- newIORef emptyTypeEnv + ; let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)), + if_rec_types = Just (mod, readMutVar tc_env_var) } ; + ; if_lenv = IfLclEnv { if_mod = moduleName mod, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv } } - ; initTcRnIf 'i' hsc_env gbl_env () do_this + ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var) } + where + mod = mi_module iface initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a -- Used when sucking in new Rules in SimplCore diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 279bf81..a2849de 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -289,7 +289,7 @@ tcTyClDecl calc_vrcs calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) tcTyClDecl1 calc_vrcs calc_isrec - (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { rhs_ty' <- tcHsKindedType rhs_ty ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) } @@ -297,8 +297,8 @@ tcTyClDecl1 calc_vrcs calc_isrec arg_vrcs = calc_vrcs tc_name tcTyClDecl1 calc_vrcs calc_isrec - (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdName = tc_name, tcdCons = cons}) + (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, + tcdName = tc_name, tcdCons = cons}) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; want_generic <- doptM Opt_Generics @@ -315,9 +315,9 @@ tcTyClDecl1 calc_vrcs calc_isrec is_rec = calc_isrec tc_name tcTyClDecl1 calc_vrcs calc_isrec - (ClassDecl {tcdName = class_name, tcdTyVars = tvs, - tcdCtxt = ctxt, tcdMeths = meths, - tcdFDs = fundeps, tcdSigs = sigs} ) + (ClassDecl {tcdName = class_name, tcdTyVars = tvs, + tcdCtxt = ctxt, tcdMeths = meths, + tcdFDs = fundeps, tcdSigs = sigs} ) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM tc_fundep fundeps @@ -340,7 +340,7 @@ tcTyClDecl1 calc_vrcs calc_isrec tcTyClDecl1 calc_vrcs calc_isrec - (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name}) + (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name}) = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) -----------------------------------