From 9d2575d7bef0774c05b509854a54a57941ffb925 Mon Sep 17 00:00:00 2001 From: simonpj Date: Sat, 16 Apr 2005 22:47:25 +0000 Subject: [PATCH] [project @ 2005-04-16 22:47:23 by simonpj] Significant clean-up of the handling of hi-boot files. Previously, when compling A.hs, we loaded A.hi-boot, and it went into the External Package Table. It was strange but it worked. This tidy up stops it going anywhere; it's just read in, and typechecked into a ModDetails. All this was on the way to improving the handling of instances in hs-boot files, something Chris Ryder wanted. I think they work quite sensibly now. If I've got all this right (have not had a chance to fully test it) we can merge it into STABLE. --- ghc/compiler/iface/IfaceEnv.lhs | 17 +++- ghc/compiler/iface/LoadIface.lhs | 54 +++---------- ghc/compiler/iface/TcIface.lhs | 78 ++++++++++++++++--- ghc/compiler/main/HscMain.lhs | 5 +- ghc/compiler/rename/RnNames.lhs | 14 +--- ghc/compiler/typecheck/TcEnv.lhs | 4 +- ghc/compiler/typecheck/TcRnDriver.lhs | 128 ++++++++++++++++++------------- ghc/compiler/typecheck/TcRnMonad.lhs | 10 +-- ghc/compiler/typecheck/TcSplice.lhs | 4 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 10 +-- ghc/compiler/typecheck/TcTyDecls.lhs | 8 +- 11 files changed, 187 insertions(+), 145 deletions(-) diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index d36dce4..d55b5e2 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -4,11 +4,13 @@ module IfaceEnv ( newGlobalBinder, newIPName, newImplicitBinder, lookupIfaceTop, lookupIfaceExt, - lookupOrig, lookupAvail, lookupIfaceTc, + lookupOrig, lookupIfaceTc, newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, + lookupAvail, ifaceExportNames, + -- Name-cache stuff allocateGlobalBinder, initNameCache, ) where @@ -18,7 +20,8 @@ module IfaceEnv ( import TcRnMonad import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) import TysWiredIn ( tupleTyCon, tupleCon ) -import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), OrigNameCache ) +import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), + IfaceExport, OrigNameCache ) import TyCon ( TyCon, tyConName ) import DataCon ( dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) @@ -27,7 +30,7 @@ import Name ( Name, nameUnique, nameModule, getOccName, nameParent_maybe, isWiredInName, mkIPName, mkExternalName, mkInternalName ) - +import NameSet ( NameSet, emptyNameSet, addListToNameSet ) import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) import PrelNames ( gHC_PRIM, pREL_TUP ) @@ -127,6 +130,14 @@ newImplicitBinder base_name mk_sys_occ Just parent_name -> parent_name Nothing -> base_name +ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet +ifaceExportNames exports + = foldlM do_one emptyNameSet exports + where + do_one acc (mod, exports) = foldlM (do_avail mod) acc exports + do_avail mod acc avail = do { ns <- lookupAvail mod avail + ; return (addListToNameSet acc ns) } + lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name] -- Find all the names arising from an import -- Make sure the parent info is correct, even though we may not diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 20142bf..28c9770 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -6,8 +6,8 @@ \begin{code} module LoadIface ( loadHomeInterface, loadInterface, loadDecls, - loadSrcInterface, loadOrphanModules, loadHiBootInterface, - readIface, -- Used when reading the module's old interface + loadSrcInterface, loadOrphanModules, + findAndReadIface, readIface, -- Used when reading the module's old interface predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags, initExternalPackageState ) where @@ -83,52 +83,16 @@ loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface -- This is called for each 'import' declaration in the source code -- On a failure, fail in the monad with an error message -loadSrcInterface doc mod_name want_boot - = do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name - (ImportByUser want_boot) +loadSrcInterface doc mod want_boot + = do { mb_iface <- initIfaceTcRn $ + loadInterface doc mod (ImportByUser want_boot) ; case mb_iface of - Failed err -> failWithTc (elaborate err) + Failed err -> failWithTc (elaborate err) Succeeded iface -> return iface } where elaborate err = hang (ptext SLIT("Failed to load interface for") <+> - quotes (ppr mod_name) <> colon) 4 err - -loadHiBootInterface :: TcRn [Name] --- Load the hi-boot iface for the module being compiled, --- if it indeed exists in the transitive closure of imports --- Return the list of names exported by the hi-boot file -loadHiBootInterface - = do { eps <- getEps - ; mod <- getModule - - ; traceIf (text "loadHiBootInterface" <+> ppr mod) - - -- We're read all the direct imports by now, so eps_is_boot will - -- record if any of our imports mention us by way of hi-boot file - ; case lookupModuleEnv (eps_is_boot eps) mod of { - Nothing -> return [] ; -- The typical case - - Just (_, False) -> -- Someone below us imported us! - -- This is a loop with no hi-boot in the way - failWithTc (moduleLoop mod) ; - - Just (mod_nm, True) -> -- There's a hi-boot interface below us - - - do { -- Load it (into the PTE), and return the exported names - iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True - ; ns_s <- sequenceM [ lookupAvail mod_nm avail - | (mod,avails) <- mi_exports iface, - avail <- avails ] - ; return (concat ns_s) - }}} - where - mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod - <+> ptext SLIT("to compare against the Real Thing") - - moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) - <+> ptext SLIT("depends on itself") + quotes (ppr mod) <> colon) 4 err loadOrphanModules :: [Module] -> TcM () loadOrphanModules mods @@ -551,7 +515,7 @@ findAndReadIface :: Bool -- True <=> explicit user import -> SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> IfM lcl (MaybeErr Message (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -626,7 +590,7 @@ findHiFile hsc_env explicit mod_name hi_boot_file \begin{code} readIface :: Module -> String -> IsBootInterface - -> IfM lcl (MaybeErr Message ModIface) + -> TcRnIf gbl lcl (MaybeErr Message ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index a2cfbed..195e99d 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -5,7 +5,8 @@ \begin{code} module TcIface ( - tcImportDecl, typecheckIface, tcIfaceDecl, tcIfaceGlobal, + tcImportDecl, tcHiBootIface, typecheckIface, + tcIfaceDecl, tcIfaceGlobal, loadImportedInsts, loadImportedRules, tcExtCoreBindings ) where @@ -14,11 +15,11 @@ module TcIface ( import IfaceSyn import LoadIface ( loadHomeInterface, loadInterface, predInstGates, - loadDecls ) + loadDecls, findAndReadIface ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, - newIfaceName, newIfaceNames ) + tcIfaceTyVar, tcIfaceLclId, + newIfaceName, newIfaceNames, ifaceExportNames ) import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad @@ -30,6 +31,7 @@ import TyCon ( TyCon, tyConName, isSynTyCon ) import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, HscEnv, TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), ModGuts, + emptyModDetails, extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds ) import InstEnv ( extendInstEnvList ) import CoreSyn @@ -55,7 +57,7 @@ import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) -import Module ( Module ) +import Module ( Module, lookupModuleEnv ) import UniqSupply ( initUs_ ) import Outputable import ErrUtils ( Message ) @@ -167,11 +169,12 @@ 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 :: HscEnv - -> ModIface -- Get the decls from here - -> IO ModDetails -typecheckIface hsc_env iface - = initIfaceTc hsc_env iface $ \ tc_env_var -> do +typecheckIface :: ModIface -- Get the decls from here + -> TcRnIf gbl lcl ModDetails +typecheckIface iface + = initIfaceTc iface $ \ tc_env_var -> do + -- The tc_env_var is freshly allocated, private to + -- type-checking this particular interface { -- 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 @@ -193,8 +196,14 @@ typecheckIface hsc_env iface ; dfuns <- mapM tcIfaceInst dfuns ; rules <- mapM tcIfaceRule rules + -- Exports + ; exports <- ifaceExportNames (mi_exports iface) + -- Finished - ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules }) + ; return (ModDetails { md_types = type_env, + md_insts = dfuns, + md_rules = rules, + md_exports = exports }) } \end{code} @@ -205,6 +214,53 @@ typecheckIface hsc_env iface %* * %************************************************************************ +\begin{code} +tcHiBootIface :: Module -> TcRn ModDetails +-- Load the hi-boot iface for the module being compiled, +-- if it indeed exists in the transitive closure of imports +-- Return the ModDetails, empty if no hi-boot iface +tcHiBootIface mod + = do { traceIf (text "loadHiBootInterface" <+> ppr mod) + + -- We're read all the direct imports by now, so eps_is_boot will + -- record if any of our imports mention us by way of hi-boot file + ; eps <- getEps + ; case lookupModuleEnv (eps_is_boot eps) mod of { + Nothing -> return emptyModDetails ; -- The typical case + + Just (_, False) -> failWithTc moduleLoop ; + -- Someone below us imported us! + -- This is a loop with no hi-boot in the way + + Just (mod, True) -> -- There's a hi-boot interface below us + + do { read_result <- findAndReadIface + True -- Explicit import? + need mod + True -- Hi-boot file + + ; case read_result of + Failed err -> failWithTc (elaborate err) + Succeeded (iface, _path) -> typecheckIface iface + }}} + where + need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod + <+> ptext SLIT("to compare against the Real Thing") + + moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) + <+> ptext SLIT("depends on itself") + + elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+> + quotes (ppr mod) <> colon) 4 err +\end{code} + + +%************************************************************************ +%* * + Type and class declarations +%* * +%************************************************************************ + When typechecking a data type decl, we *lazily* (via forkM) typecheck the constructor argument types. This is in the hope that we may never poke on those argument types, and hence may never need to load the diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 4d1fe47..404c7ed 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -51,8 +51,8 @@ import Parser import Lexer ( P(..), ParseResult(..), mkPState ) import SrcLoc ( mkSrcLoc ) import TcRnDriver ( tcRnModule, tcRnExtCore ) -import TcRnTypes ( TcGblEnv(..) ) import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) @@ -208,7 +208,8 @@ hscNoRecomp hsc_env msg_act mod_summary "Skipping " ++ showModMsg have_object mod_summary) ; new_details <- {-# SCC "tcRnIface" #-} - typecheckIface hsc_env old_iface ; + initIfaceCheck hsc_env $ + typecheckIface old_iface ; ; dumpIfaceStats hsc_env ; return (HscNoRecomp new_details old_iface) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 8a8cc321..241863a 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -7,7 +7,7 @@ module RnNames ( rnImports, importsFromLocalDecls, reportUnusedNames, reportDeprecations, - mkModDeps, exportsToAvails, exportsFromAvail + mkModDeps, exportsFromAvail ) where #include "HsVersions.h" @@ -18,7 +18,7 @@ import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, Sig(..), collectGroupBinders, tyClDeclNames ) import RnEnv -import IfaceEnv ( lookupAvail ) +import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad @@ -183,7 +183,7 @@ importsFromImportDecl this_mod is_loc = loc, is_as = qual_mod_name } in -- Get the total imports, and filter them according to the import list - exportsToAvails filtered_exports `thenM` \ total_avails -> + ifaceExportNames filtered_exports `thenM` \ total_avails -> filterImports iface imp_spec imp_details total_avails `thenM` \ (avail_env, gbl_env) -> @@ -246,14 +246,6 @@ importsFromImportDecl this_mod returnM (gbl_env, imports) -exportsToAvails :: [IfaceExport] -> TcRnIf gbl lcl NameSet -exportsToAvails exports - = foldlM do_one emptyNameSet exports - where - do_one acc (mod, exports) = foldlM (do_avail mod) acc exports - do_avail mod acc avail = do { ns <- lookupAvail mod avail - ; return (addListToNameSet acc ns) } - warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (ppr mod_name) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 9b2ce42..8caa51d 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -499,8 +499,8 @@ other modules \begin{code} newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name newDFunName clas (ty:_) loc - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc) + = do { uniq <- newUnique + ; return (mkInternalName uniq (mkDFunOcc dfun_string) loc) } where -- Any string that is somewhat unique will do dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index fbd13d8..045577b 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -43,14 +43,14 @@ import Inst ( showLIE ) import InstEnv ( extendInstEnvList ) import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv ) +import TcEnv ( tcExtendGlobalValEnv, iDFunId ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( tcExtCoreBindings ) +import TcIface ( tcExtCoreBindings, tcHiBootIface ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) -import LoadIface ( loadOrphanModules, loadHiBootInterface ) +import LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) @@ -63,17 +63,19 @@ import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName ) +import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, + getOccName, isWiredInName ) import NameSet import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) -import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), +import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, + HscEnv(..), ExternalPackageState(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), - TypeEnv, lookupTypeEnv, hptInstances, lookupType, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, + TypeEnv, lookupTypeEnv, hptInstances, + extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, emptyFixityEnv ) import Outputable @@ -100,14 +102,13 @@ import RnTypes ( rnLHsType ) import Inst ( tcGetInstEnvs ) import InstEnv ( DFunId, classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) -import RnNames ( exportsToAvails ) import LoadIface ( loadSrcInterface, ifaceInstGates ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), tyThingToIfaceDecl, dfunToIfaceInst ) import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType, interactiveExtNameFun, isLocalIfaceExtName ) -import IfaceEnv ( lookupOrig ) +import IfaceEnv ( lookupOrig, ifaceExportNames ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId, setIdType, globalIdDetails ) import MkId ( unsafeCoerceId ) @@ -297,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ; + tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ; -- Make the new type env available to stuff slurped from interface files setGblEnv tcg_env $ do { @@ -359,10 +360,11 @@ tcRnSrcDecls decls -- We do this now so that the boot_names can be passed -- to tcTyAndClassDecls, because the boot_names are -- automatically considered to be loop breakers - boot_names <- loadHiBootInterface ; + mod <- getModule ; + boot_iface <- tcHiBootIface mod ; -- Do all the declarations - (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ; + (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a @@ -386,27 +388,29 @@ tcRnSrcDecls decls (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; - let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; + let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; tcg_env' = tcg_env { tcg_type_env = final_type_env, + tcg_binds = binds', tcg_rules = rules', + tcg_fords = fords' } } ; - -- Compre the hi-boot iface (if any) with the real thing - checkHiBootIface final_type_env boot_names ; + -- Compare the hi-boot iface (if any) with the real thing + checkHiBootIface tcg_env' boot_iface ; -- Make the new type env available to stuff slurped from interface files writeMutVar (tcg_type_env_var tcg_env) final_type_env ; - return (tcg_env { tcg_type_env = final_type_env, - tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) + return tcg_env' } -tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) +tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module -tc_rn_src_decls boot_names ds +tc_rn_src_decls boot_details ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ; + tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ; -- Bale out if errors; for example, error recovery when checking -- the RHS of 'main' can mean that 'main' is not in the envt for @@ -437,7 +441,7 @@ tc_rn_src_decls boot_names ds -- Glue them on the front of the remaining decls and loop setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls boot_names (spliced_decls ++ rest_ds) + tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ }}} \end{code} @@ -467,7 +471,7 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc (text "Tc2") ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls) + ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls) ; setGblEnv tcg_env $ do { -- Typecheck instance decls @@ -477,15 +481,21 @@ tcRnHsBootDecls decls -- Typecheck value declarations ; traceTc (text "Tc5") - ; new_ids <- tcHsBootSigs (hs_valds rn_group) + ; val_ids <- tcHsBootSigs (hs_valds rn_group) -- Wrap up -- No simplification or zonking to do ; traceTc (text "Tc7a") ; gbl_env <- getGblEnv - ; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids } - ; return (gbl_env { tcg_type_env = final_type_env }) + -- Make the final type-env + -- Include the dfun_ids so that their type sigs get + -- are written into the interface file + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos } + ; return (gbl_env { tcg_type_env = type_env2 }) }}}} spliceInHsBootErr (SpliceDecl (L loc _), _) @@ -499,33 +509,38 @@ the hi-boot stuff in the EPT. We do so here, using the export list of the hi-boot interface as our checklist. \begin{code} -checkHiBootIface :: TypeEnv -> [Name] -> TcM () +checkHiBootIface :: TcGblEnv -> ModDetails -> TcM () -- Compare the hi-boot file for this module (if there is one) -- with the type environment we've just come up with -- In the common case where there is no hi-boot file, the list -- of boot_names is empty. -checkHiBootIface env boot_names - = mapM_ (check_one env) boot_names - ----------------- -check_one local_env name - | isWiredInName name -- No checking for wired-in names. In particular, 'error' - = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot) - | otherwise - = do { (eps,hpt) <- getEpsAndHpt - - -- Look up the hi-boot one; - -- it should jolly well be there (else GHC bug) - ; case lookupType hpt (eps_PTE eps) name of { - Nothing -> pprPanic "checkHiBootIface" (ppr name) ; - Just boot_thing -> - - -- Look it up in the local type env - -- It should be there, but it's a programmer error if not - case lookupTypeEnv local_env name of - Nothing -> addErrTc (missingBootThing boot_thing) - Just real_thing -> check_thing boot_thing real_thing - } } +checkHiBootIface + (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env }) + (ModDetails { md_insts = boot_insts, md_types = boot_type_env }) + = do { mapM_ check_inst boot_insts + ; mapM_ check_one (typeEnvElts boot_type_env) } + where + check_one boot_thing + | no_check name + = return () + | otherwise + = case lookupTypeEnv local_type_env name of + Nothing -> addErrTc (missingBootThing boot_thing) + Just real_thing -> check_thing boot_thing real_thing + where + name = getName boot_thing + + no_check name = isWiredInName name -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) + || name `elem` dfun_names + dfun_names = map getName boot_insts + + check_inst inst + | null [i | i <- local_insts, idType i `tcEqType` idType inst] + = addErrTc (instMisMatch inst) + | otherwise + = return () ---------------- check_thing (ATyCon boot_tc) (ATyCon real_tc) @@ -558,6 +573,9 @@ missingBootThing thing = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") bootMisMatch thing = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") +instMisMatch inst + = hang (ptext SLIT("instance") <+> ppr (idType inst)) + 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) \end{code} @@ -579,15 +597,15 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) +tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup boot_names decls +tcRnGroup boot_details decls = do { -- Rename the declarations (tcg_env, rn_decls) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tcTopSrcDecls boot_names rn_decls + tcTopSrcDecls boot_details rn_decls }} ------------------------------------------------ @@ -613,8 +631,8 @@ rnTopSrcDecls group }} ------------------------------------------------ -tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls boot_names +tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls boot_details (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls, @@ -625,7 +643,7 @@ tcTopSrcDecls boot_names -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ; + tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ; -- tcTyAndClassDecls recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade @@ -1051,7 +1069,7 @@ getModuleExports mod ; loadOrphanModules (dep_orphs (mi_deps iface)) -- Load any orphan-module interfaces, -- so their instances are visible - ; names <- exportsToAvails (mi_exports iface) + ; names <- ifaceExportNames (mi_exports iface) ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod } | name <- nameSetToList names ] } ; returnM (mkGlobalRdrEnv gres) } diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 6ff9043..ac5e59a 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -836,16 +836,16 @@ initIfaceCheck hsc_env do_this ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceTc :: HscEnv -> ModIface - -> (TcRef TypeEnv -> IfL a) -> IO a +initIfaceTc :: ModIface + -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl 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 { tc_env_var <- newIORef emptyTypeEnv +initIfaceTc iface do_this + = do { tc_env_var <- newMutVar emptyTypeEnv ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; ; if_lenv = mkIfLclEnv mod doc } - ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var) + ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var) } where mod = mi_module iface diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index d872de5..08e89b5 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -37,7 +37,7 @@ import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, mkInternalName, nameIsLocalOrFrom ) import NameEnv ( lookupNameEnv ) -import HscTypes ( lookupType, ExternalPackageState(..) ) +import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails ) import OccName import Var ( Id, TyVar, idType ) import Module ( moduleUserString, mkModule ) @@ -141,7 +141,7 @@ tc_bracket (TypBr typ) -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) - = tcTopSrcDecls [{- no boot-names -}] decls `thenM_` + = tcTopSrcDecls emptyModDetails decls `thenM_` -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index b3b3de6..7186fa9 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -17,7 +17,7 @@ import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ) import HsTypes ( HsBang(..), getBangStrictness ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) -import HscTypes ( implicitTyThings ) +import HscTypes ( implicitTyThings, ModDetails ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad @@ -109,15 +109,15 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. \begin{code} -tcTyAndClassDecls :: [Name] -> [LTyClDecl Name] +tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons -tcTyAndClassDecls boot_names decls +tcTyAndClassDecls boot_details decls = do { -- First check for cyclic type synonysm or classes -- See notes with checkCycleErrs checkCycleErrs decls ; mod <- getModule - ; traceTc (text "tcTyAndCl" <+> ppr mod <+> ppr boot_names) + ; traceTc (text "tcTyAndCl" <+> ppr mod) ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> do { let { -- Calculate variances and rec-flag ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls } @@ -135,7 +135,7 @@ tcTyAndClassDecls boot_names decls { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss) - ; calc_rec = calcRecFlags boot_names rec_alg_tyclss + ; calc_rec = calcRecFlags boot_details rec_alg_tyclss ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) } -- Type-check the type synonyms, and extend the envt ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 105bef9..590ac2c 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -23,7 +23,7 @@ import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl ) import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep ) -import HscTypes ( TyThing(..) ) +import HscTypes ( TyThing(..), ModDetails(..) ) import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars, getSynTyConDefn, isSynTyCon, isAlgTyCon, tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs ) @@ -213,16 +213,16 @@ recursiveness, because we need only look at the type decls in the module being compiled, plus the outer structure of directly-mentioned types. \begin{code} -calcRecFlags :: [Name] -> [TyThing] -> (Name -> RecFlag) +calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag) -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module. -- Any type constructors in boot_names are automatically considered loop breakers -calcRecFlags boot_names tyclss +calcRecFlags boot_details tyclss = is_rec where is_rec n | n `elemNameSet` rec_names = Recursive | otherwise = NonRecursive - boot_name_set = mkNameSet boot_names + boot_name_set = md_exports boot_details rec_names = boot_name_set `unionNameSets` nt_loop_breakers `unionNameSets` prod_loop_breakers -- 1.7.10.4