From 84f4c1dfb0c39c5b48a8b960fc82ab10aeb10c84 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 6 Oct 2006 13:19:32 +0000 Subject: [PATCH] Fix up the typechecking of interface files during --make This patch fixes Trac #909. The problem was that when compiling the base package, the handling of wired-in things wasn't right; in TcIface.tcWiredInTyCon it repeatedly loaded GHC.Base.hi into the PIT, even though that was the very module it was compiling. The main fix is by introducing TcIface.ifCheckWiredInThing. But I did some minor refactoring as well. --- compiler/iface/LoadIface.lhs | 38 +++++++------- compiler/iface/TcIface.lhs | 94 ++++++++++++++++++++++------------- compiler/iface/TcIface.lhs-boot | 4 +- compiler/typecheck/TcTyClsDecls.lhs | 1 + 4 files changed, 79 insertions(+), 58 deletions(-) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index d4cd503..0dbb17e 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -8,20 +8,19 @@ module LoadIface ( loadInterface, loadInterfaceForName, loadWiredInHomeIface, loadSrcInterface, loadSysInterface, loadOrphanModules, findAndReadIface, readIface, -- Used when reading the module's old interface - loadDecls, ifaceStats, discardDeclPrags, + loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, - pprModIface, showIface -- Print the iface in Foo.hi + ifaceStats, pprModIface, showIface -- Print the iface in Foo.hi ) where #include "HsVersions.h" -import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) +import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst ) import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), - IfaceConDecls(..), IfaceFamInst(..), - IfaceIdInfo(..) ) + IfaceConDecls(..), IfaceFamInst(..) ) import IfaceEnv ( newGlobalBinder, lookupIfaceTc ) import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), Deprecs(..), Dependencies(..), @@ -157,6 +156,9 @@ loadSysInterface doc mod_name loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr Message ModIface) +-- loadInterface looks in both the HPT and PIT for the required interface +-- If not found, it loads it, and puts it in the PIT (always). + -- If it can't find a suitable interface file, we -- a) modify the PackageIfaceTable to have an empty entry -- (to avoid repeated complaints) @@ -240,9 +242,7 @@ loadInterface doc_str mod from ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) - ; new_eps_rules <- if ignore_prags - then return [] - else mapM tcIfaceRule (mi_rules iface) + ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", @@ -261,8 +261,8 @@ loadInterface doc_str mod from badDepMsg mod = hang (ptext SLIT("Interface file inconsistency:")) - 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"), - ptext SLIT("but does not appear in the dependencies of the interface")]) + 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned is needed,"), + ptext SLIT("but is not among the dependencies of interfaces directly imported by the module being compiled")]) ----------------------------------------------------- -- Loading type/class/value decls @@ -305,18 +305,21 @@ loadDecl ignore_prags mod (_version, decl) (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily - -- NB. firstly, the laziness is there in case we never need the + -- NB. Firstly, the laziness is there in case we never need the -- declaration (in one-shot mode), and secondly it is there so that -- we don't look up the occurrence of a name before calling mk_new_bndr -- on the binder. This is important because we must get the right name -- which includes its nameParent. - ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl) + + ; thing <- forkM doc $ do { bumpDeclStats main_name + ; tcIfaceDecl ignore_prags decl } + + -- Populate the type environment with the implicitTyThings too ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing Nothing -> - pprPanic "loadDecl" (ppr main_name <+> - ppr n $$ ppr (stripped_decl)) + pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names] } @@ -324,9 +327,6 @@ loadDecl ignore_prags mod (_version, decl) -- as the TyThings. That way we can extend the PTE without poking the -- thunks where - stripped_decl | ignore_prags = discardDeclPrags decl - | otherwise = decl - -- mk_new_bndr allocates in the name cache the final canonical -- name for the thing, with the correct -- * parent @@ -344,10 +344,6 @@ loadDecl ignore_prags mod (_version, decl) doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) -discardDeclPrags :: IfaceDecl -> IfaceDecl -discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo } -discardDeclPrags decl = decl - bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used bumpDeclStats name = do { traceIf (text "Loading decl for" <+> ppr name) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 099fd9a..ac458d5 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -6,15 +6,14 @@ \begin{code} module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal, + tcIfaceDecl, tcIfaceInst, tcIfaceRules, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadInterface, loadWiredInHomeIface, - loadDecls, findAndReadIface ) +import LoadIface ( loadInterface, loadWiredInHomeIface, findAndReadIface, loadDecls ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, @@ -57,7 +56,6 @@ import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, import NameEnv import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, pprNameSpace, occNameFS ) -import FastString ( FastString ) import Module ( Module, moduleName ) import UniqFM ( lookupUFM ) import UniqSupply ( initUs_, uniqsFromSupply ) @@ -67,6 +65,7 @@ import Maybes ( MaybeErr(..) ) import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual ) import DynFlags ( DynFlag(..), isOneShot ) +import Control.Monad ( unless ) import List ( elemIndex) import Maybe ( catMaybes ) @@ -138,12 +137,11 @@ checkWiredInTyCon tc = return () | otherwise = do { mod <- getModule - ; if nameIsLocalOrFrom mod tc_name then + ; unless (mod == nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) -- Don't look for (non-existent) Float.hi when -- compiling Float.lhs, which mentions Float of course - return () - else -- A bit yukky to call initIfaceTcRn here - initIfaceTcRn (loadWiredInHomeIface tc_name) + -- A bit yukky to call initIfaceTcRn here } where tc_name = tyConName tc @@ -203,24 +201,24 @@ typecheckIface iface -- 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 + -- Typecheck the decls. This is done lazily, so that the knot-tying + -- within this single module work out right. In the If monad there is + -- no global envt for the current interface; instead, the knot is tied + -- through the if_rec_types field of IfGblEnv + ; names_w_things <- loadDecls ignore_prags (mi_decls iface) + ; let type_env = mkNameEnv names_w_things ; writeMutVar tc_env_var type_env -- Now do those rules and instances - ; let { rules | ignore_prags = [] - | otherwise = mi_rules iface - ; dfuns = mi_insts iface - } - ; dfuns <- mapM tcIfaceInst dfuns - ; rules <- mapM tcIfaceRule rules + ; dfuns <- mapM tcIfaceInst (mi_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) -- Exports - ; exports <- ifaceExportNames (mi_exports iface) + ; exports <- ifaceExportNames (mi_exports iface) -- Finished + ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), + text "Type envt:" <+> ppr type_env]) ; return $ ModDetails { md_types = type_env , md_insts = dfuns , md_fam_insts = mkDetailsFamInstCache type_env @@ -349,15 +347,18 @@ the forkM stuff. \begin{code} -tcIfaceDecl :: IfaceDecl -> IfL TyThing +tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing -tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) +tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type - ; info <- tcIdInfo name ty info + ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkVanillaGlobal name ty info)) } -tcIfaceDecl (IfaceData {ifName = occ_name, +tcIfaceDecl ignore_prags + (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, @@ -387,7 +388,8 @@ tcIfaceDecl (IfaceData {ifName = occ_name, ; return (ATyCon tycon) }} -tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, +tcIfaceDecl ignore_prags + (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name @@ -397,7 +399,8 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) } -tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, +tcIfaceDecl ignore_prags + (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, ifRec = tc_isrec }) @@ -408,7 +411,7 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ; ctxt <- tcIfaceCtxt rdr_ctxt ; sigs <- mappM tc_sig rdr_sigs ; fds <- mappM tc_fd rdr_fds - ; ats' <- mappM tcIfaceDecl rdr_ats + ; ats' <- mappM (tcIfaceDecl ignore_prags) rdr_ats ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } @@ -440,7 +443,7 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ATyCon (setTyConArgPoss tycon poss) setTyThingPoss _ _ = panic "TcIface.setTyThingPoss" -tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) +tcIfaceDecl ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0)) } @@ -529,6 +532,13 @@ 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} +tcIfaceRules :: Bool -- True <=> ignore rules + -> [IfaceRule] + -> IfL [CoreRule] +tcIfaceRules ignore_prags if_rules + | ignore_prags = return [] + | otherwise = mapM tcIfaceRule if_rules + tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, @@ -760,9 +770,12 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} -tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo -tcIdInfo name ty NoInfo = return vanillaIdInfo -tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info +tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo +tcIdInfo ignore_prags name ty info + | ignore_prags = return vanillaIdInfo + | otherwise = case info of + NoInfo -> return vanillaIdInfo + 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 @@ -859,10 +872,7 @@ tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name -- Wired-in things include TyCons, DataCons, and Ids - = do { loadWiredInHomeIface name; return thing } - -- Even though we are in an interface file, we want to make - -- sure its instances are loaded (imagine f :: Double -> Double) - -- and its RULES are loaded too + = do { ifCheckWiredInThing name; return thing } | otherwise = do { (eps,hpt) <- getEpsAndHpt ; dflags <- getDOpts @@ -889,6 +899,20 @@ tcIfaceGlobal name Succeeded thing -> return thing }}}}} +ifCheckWiredInThing :: Name -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +ifCheckWiredInThing name + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; unless (mod == nameModule name) + (loadWiredInHomeIface name) } + tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon @@ -918,7 +942,7 @@ tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- sure the instances and RULES of this tycon are loaded -- Imagine: f :: Double -> Double tcWiredInTyCon :: TyCon -> IfL TyCon -tcWiredInTyCon tc = do { loadWiredInHomeIface (tyConName tc) +tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc) ; return tc } tcIfaceClass :: IfaceExtName -> IfL Class diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index 25191fc..e9ed235 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -6,8 +6,8 @@ import TcRnTypes ( IfL ) import InstEnv ( Instance ) import CoreSyn ( CoreRule ) -tcIfaceDecl :: IfaceDecl -> IfL TyThing +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] tcIfaceInst :: IfaceInst -> IfL Instance -tcIfaceRule :: IfaceRule -> IfL CoreRule \end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index dee20ee..eee2041 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -196,6 +196,7 @@ tcTyAndClassDecls boot_details allDecls ; let { -- Calculate rec-flag ; calc_rec = calcRecFlags boot_details rec_alg_tyclss ; tc_decl = addLocM (tcTyClDecl calc_rec) } + -- Type-check the type synonyms, and extend the envt ; syn_tycons <- tcSynDecls kc_syn_decls ; tcExtendGlobalEnv syn_tycons $ do -- 1.7.10.4