From aa44169c3c01243cdbf38f50f58e80477586552c Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 23 Oct 2000 09:03:30 +0000 Subject: [PATCH] [project @ 2000-10-23 09:03:26 by simonpj] Mainly renamer --- ghc/compiler/NOTES | 47 +--- ghc/compiler/basicTypes/Id.lhs | 16 +- ghc/compiler/basicTypes/IdInfo.lhs | 1 - ghc/compiler/basicTypes/Module.lhs | 6 +- ghc/compiler/coreSyn/CoreFVs.lhs | 2 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 2 - ghc/compiler/coreSyn/CoreUtils.lhs | 13 +- ghc/compiler/coreSyn/PprCore.lhs | 5 +- ghc/compiler/ghci/CmLink.lhs | 5 +- ghc/compiler/hsSyn/HsBinds.lhs | 2 +- ghc/compiler/hsSyn/HsMatches.lhs | 3 +- ghc/compiler/hsSyn/HsPat.lhs | 2 +- ghc/compiler/hsSyn/HsTypes.lhs | 16 +- ghc/compiler/main/DriverPipeline.hs | 23 +- ghc/compiler/main/Finder.lhs | 17 +- ghc/compiler/main/HscMain.lhs | 16 +- ghc/compiler/main/HscTypes.lhs | 170 +++++++------- ghc/compiler/main/TmpFiles.hs | 4 +- ghc/compiler/parser/Lex.lhs | 2 +- ghc/compiler/parser/RdrHsSyn.lhs | 1 - ghc/compiler/prelude/PrelInfo.lhs | 46 ++-- ghc/compiler/prelude/PrelRules.lhs | 1 - ghc/compiler/rename/Rename.lhs | 59 ++--- ghc/compiler/rename/RnEnv.lhs | 9 +- ghc/compiler/rename/RnIfaces.lhs | 413 ++++++++++++---------------------- ghc/compiler/rename/RnMonad.lhs | 64 ++++-- ghc/compiler/rename/RnNames.lhs | 29 --- ghc/compiler/simplCore/OccurAnal.lhs | 2 - ghc/compiler/stgSyn/StgInterp.lhs | 8 +- ghc/compiler/types/FunDeps.lhs | 1 - ghc/compiler/types/Unify.lhs | 6 +- 31 files changed, 374 insertions(+), 617 deletions(-) diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES index 2809640..1837796 100644 --- a/ghc/compiler/NOTES +++ b/ghc/compiler/NOTES @@ -1,45 +1,4 @@ -Notes July 00 -~~~~~~~~~~~~~~ -Time.lhs: fails with too many arguments to C function -works with native code gen - -CTypes.lhs: fails with - /tmp/ghc2840.hc:42413: fixed or forbidden register 3 (bx) was spilled for class GENERAL_REGS. - This may be due to a compiler bug or to impossible asm statements or clauses. -works without -O - -posix/* fails with - ghc1653.c:4: `#include' expects "FILENAME" or - ghc1653.c:6: `#include' expects "FILENAME" or -works when one fixes the makefile - -make depend needs the -osuf o removed. - -CTypes also has a Subst-worker WARNING. - - -Notes June 99 -~~~~~~~~~~~~~ -* In nofib/spectral/mandel2/Main.check_radius, there's a call to (fromIntegral m), where - m is defined at top level. The full-laziness pass doesn't catch this because by - the time it runs, enough inlining has happened that it looks like - case ccall ... of (# a,b #) -> ... - and the full laziness pass doesn't float unboxed things. - -* The same function is an excellent example of where liberate-case would be a win. - -* Don't forget to try CSE - -Interface files -~~~~~~~~~~~~~~~ -* Don't need to pin a kind on the type variable in a interface class decl, - because it'll be correctly re-inferred when we read it in. - -* The double semicolon at the end of an interface-file signature is so that - the lexer can run through the pragmas very fast when -O isn't being used. - -* In export lists, T|(A,B) says that constructors A and B are exported, - but not the type T. Similarly for classes. - We can't say T(T,A,B) and T(A,B) to export or not-export T respectively, - because the type T might have a constructor T. +21 Oct 00 +- Do we want to continue to record the package name in an interface file? + Does pi_mod have a Module or a ModuleName? diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index ae1b799..2a281b6 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -70,8 +70,7 @@ module Id ( #include "HsVersions.h" -import CoreSyn ( Unfolding, CoreRules, CoreExpr, Expr(..), - AltCon (..), Alt, mkApps, Arg ) +import CoreSyn ( Unfolding, CoreRules ) import BasicTypes ( Arity ) import Var ( Id, DictId, isId, mkIdVar, @@ -83,30 +82,23 @@ import Var ( Id, DictId, ) import VarSet import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, - seqType, splitAlgTyConApp_maybe, mkTyVarTy, - mkTyConApp, splitTyConApp_maybe) + seqType, splitTyConApp_maybe ) import IdInfo -import Demand ( Demand, isStrict, wwLazy ) +import Demand ( Demand ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, isUserExportedName, getOccName, isIPOcc ) import OccName ( UserFS ) import PrimRep ( PrimRep ) -import PrimOp ( PrimOp, primOpIsCheap ) import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques, getNumBuiltinUniques ) -import Outputable -import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, - mkAlgTyConRep, tyConName, - tyConTyVars, tyConDataCons ) -import DataCon ( DataCon, dataConWrapId, dataConOrigArgTys ) -import Var ( Var ) + infixl 1 `setIdUnfolding`, `setIdArityInfo`, `setIdDemandInfo`, diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 0db72f1..3fe281a 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -80,7 +80,6 @@ import DataCon ( DataCon ) import FieldLabel ( FieldLabel ) import Demand -- Lots of stuff import Outputable -import Maybe ( isJust ) infixl 1 `setDemandInfo`, `setStrictnessInfo`, diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 44bf44b..426fdf4 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -56,7 +56,7 @@ module Module , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv - , rngModuleEnv, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv + , rngModuleEnv, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv, lookupModuleEnvByName ) where @@ -276,7 +276,8 @@ mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b rngModuleEnv :: ModuleEnv a -> [a] isEmptyModuleEnv :: ModuleEnv a -> Bool -lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnvByName:: ModuleEnv a -> ModuleName -> Maybe a lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a elemModuleEnv :: Module -> ModuleEnv a -> Bool foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b @@ -289,6 +290,7 @@ delModuleEnvList = delListFromUFM delModuleEnv = delFromUFM plusModuleEnv = plusUFM lookupModuleEnv = lookupUFM +lookupModuleEnvByName = lookupUFM lookupWithDefaultModuleEnv = lookupWithDefaultUFM mapModuleEnv = mapUFM mkModuleEnv = listToUFM diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 42dcee8..09d1ae1 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -22,7 +22,7 @@ import Id ( Id, idFreeTyVars, hasNoBinding, idSpecialisation ) import VarSet import Var ( Var, isId ) import Name ( isLocallyDefined ) -import Type ( tyVarsOfType, Type ) +import Type ( tyVarsOfType ) import Util ( mapAndUnzip ) import Outputable \end{code} diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 4ed1cb4..ac41b7b 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -355,8 +355,6 @@ data ExprSize = TooBig FastInt -- Size to subtract if result is scrutinised -- by a case expression -isTooBig TooBig = True -isTooBig _ = False maxSize TooBig _ = TooBig maxSize _ TooBig = TooBig diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 24b1f35..012075c 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -41,8 +41,8 @@ import PprCore ( pprCoreExpr ) import Var ( Var, isId, isTyVar ) import VarSet import VarEnv -import Name ( isLocallyDefined, hashName ) -import Literal ( Literal, hashLiteral, literalType, litIsDupable ) +import Name ( hashName ) +import Literal ( hashLiteral, literalType, litIsDupable ) import DataCon ( DataCon, dataConRepArity ) import PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable ) @@ -50,17 +50,16 @@ import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, isDataConId_maybe, isPrimOpId_maybe ) -import IdInfo ( arityLowerBound, InlinePragInfo(..), - LBVarInfo(..), +import IdInfo ( LBVarInfo(..), IdFlavour(..), megaSeqIdInfo ) import Demand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, - splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes, + splitFunTy_maybe, isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..), applyTys, isUnLiftedType, seqType ) -import TysWiredIn ( boolTy, stringTy, trueDataCon, falseDataCon ) +import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import Maybes ( maybeToBool ) import Outputable @@ -702,8 +701,6 @@ noteSize InlineCall = 1 noteSize InlineMe = 1 noteSize (TermUsg usg) = usg `seq` 1 -exprsSize = foldr ((+) . exprSize) 0 - varSize :: Var -> Int varSize b | isTyVar b = 1 | otherwise = seqType (idType b) `seq` diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 0c9ad37..184d95f 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -23,11 +23,10 @@ import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, idInfo, idInlinePragma, idDemandInfo, idOccInfo ) import Var ( isTyVar ) -import IdInfo ( IdInfo, megaSeqIdInfo, occInfo, +import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, - demandInfo, specInfo, + specInfo, cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, - cprInfo, ppCprInfo, lbvarInfo, workerInfo, ppWorkerInfo ) import DataCon ( dataConTyCon ) diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs index c7ee69f..df308e5 100644 --- a/ghc/compiler/ghci/CmLink.lhs +++ b/ghc/compiler/ghci/CmLink.lhs @@ -13,17 +13,14 @@ module CmLink ( Linkable(..), Unlinked(..), where import StgInterp ( linkIModules, ClosureEnv, ItblEnv ) -import Linker import CmStaticInfo ( PackageConfigInfo ) import Module ( ModuleName, PackageName ) import InterpSyn ( UnlinkedIBind, HValue, binder ) import Module ( Module ) import Outputable ( SDoc ) -import FiniteMap ( FiniteMap, emptyFM ) -import RdrName ( RdrName ) +import FiniteMap ( emptyFM ) import Digraph ( SCC(..) ) -import Addr ( Addr ) import Outputable import Panic ( panic ) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index f595936..0d91edf 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -16,7 +16,7 @@ import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs ) -- friends: import HsTypes ( HsType ) import CoreSyn ( CoreExpr ) -import PprCore ( {- Instances -} ) +import PprCore ( {- instance Outputable (Expr a) -} ) --others: import Name ( Name ) diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index effa2f7..cb81b7c 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -13,12 +13,11 @@ module HsMatches where -- Friends import HsExpr ( HsExpr, Stmt(..) ) import HsBinds ( HsBinds(..), nullBinds ) -import HsTypes ( HsTyVarBndr, HsType ) +import HsTypes ( HsType ) -- Others import Type ( Type ) import SrcLoc ( SrcLoc ) import Outputable -import HsPat ( InPat (..) ) import List \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 0447e3d..62c4600 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -27,7 +27,7 @@ import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) -import Name ( Name, isDataSymOcc, getOccName, NamedThing ) +import Name ( isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 1bcebd8..919bc94 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -25,10 +25,9 @@ module HsTypes ( #include "HsVersions.h" -import {-# SOURCE #-} HsExpr ( HsExpr ) import Class ( FunDep ) -import Type ( Type, Kind, PredType(..), UsageAnn(..), ClassContext, - getTyVar_maybe, splitSigmaTy, unUsgTy, boxedTypeKind +import Type ( Type, Kind, PredType(..), ClassContext, + splitSigmaTy, unUsgTy, boxedTypeKind ) import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity ) @@ -37,9 +36,8 @@ import Name ( toRdrName ) import OccName ( NameSpace ) import Var ( TyVar, tyVarKind ) import PprType ( {- instance Outputable Kind -}, pprParendKind ) -import BasicTypes ( Arity, Boxity(..), tupleParens ) -import PrelNames ( mkTupConRdrName, listTyConKey, hasKey, Uniquable(..) ) -import Maybes ( maybeToBool ) +import BasicTypes ( Boxity(..), tupleParens ) +import PrelNames ( mkTupConRdrName, listTyConKey, hasKey ) import FiniteMap import Outputable @@ -282,8 +280,6 @@ toHsTyVars tvs = map toHsTyVar tvs toHsType :: Type -> HsType RdrName toHsType ty = toHsType' (unUsgTy ty) -- For now we just discard the usage --- = case splitUsgTy ty of --- (usg, tau) -> HsUsgTy (toHsUsg usg) (toHsType' tau) toHsType' :: Type -> HsType RdrName -- Called after the usage is stripped off @@ -319,10 +315,6 @@ toHsPred (IParam n ty) = HsPIParam (toRdrName n) (toHsType ty) toHsContext :: ClassContext -> HsContext RdrName toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt] -toHsUsg UsOnce = HsUsOnce -toHsUsg UsMany = HsUsMany -toHsUsg (UsVar v) = HsUsVar (toRdrName v) - toHsFDs :: [FunDep TyVar] -> [FunDep RdrName] toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds] \end{code} diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 9a59093..981775a 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.4 2000/10/17 11:50:20 simonmar Exp $ +-- $Id: DriverPipeline.hs,v 1.5 2000/10/23 09:03:27 simonpj Exp $ -- -- GHC Driver -- @@ -44,7 +44,7 @@ import Panic import Directory import System import IOExts -import Posix +-- import Posix commented out temp by SLPJ to get going on windows import Exception import IO @@ -712,6 +712,12 @@ preprocess filename = -- reading the OPTIONS pragma from the source file, and passing the -- output of hsc through the C compiler. +-- The driver sits between 'compile' and 'hscMain', translating calls +-- to the former into calls to the latter, and results from the latter +-- into results from the former. It does things like preprocessing +-- the .hs file if necessary, and compiling up the .stub_c files to +-- generate Linkables. + compile :: Finder -- to find modules -> ModSummary -- summary, including source -> Maybe ModIFace -- old interface, if available @@ -719,6 +725,19 @@ compile :: Finder -- to find modules -> PersistentCompilerState -- persistent compiler state -> IO CompResult +data CompResult + = CompOK ModDetails -- new details (HST additions) + (Maybe (ModIface, Linkable)) + -- summary and code; Nothing => compilation not reqd + -- (old summary and code are still valid) + PersistentCompilerState -- updated PCS + (Bag WarnMsg) -- warnings + + | CompErrs PersistentCompilerState -- updated PCS + (Bag ErrMsg) -- errors + (Bag WarnMsg) -- warnings + + compile finder summary old_iface hst pcs = do verb <- readIORef verbose when verb (hPutStrLn stderr ("compile: compiling " ++ diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 7f91297..19185bf 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -13,6 +13,7 @@ module Finder ( #include "HsVersions.h" +import HscTyes ( Finder, ModuleLocation(..) ) import CmStaticInfo import DriverPhases import DriverState @@ -34,22 +35,6 @@ lives in, so it can make a Module from a ModuleName, and (b) where the source, interface, and object files for a module live. \begin{code} -type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation)) - --- For a module in another package, the hs_file and obj_file --- components of ModuleLocation are undefined. - --- The locations specified by a ModuleLocation may or may not --- correspond to actual files yet: for example, even if the object --- file doesn't exist, the ModuleLocation still contains the path to --- where the object file will reside if/when it is created. - -data ModuleLocation - = ModuleLocation { - hs_file :: FilePath, - hi_file :: FilePath, - obj_file :: FilePath - } -- caches contents of package directories, never expunged GLOBAL_VAR(pkgDirCache, Nothing, Maybe (FiniteMap String (PackageName, FilePath))) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index e9684bd..484ae8f 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -20,6 +20,7 @@ import SrcLoc ( mkSrcLoc ) import Rename ( renameModule ) +import PrelInfo ( wiredInThings ) import MkIface ( writeIface ) import TcModule ( TcResults(..), typecheckModule ) import Desugar ( deSugar ) @@ -57,6 +58,19 @@ import StgInterp ( runStgI ) %************************************************************************ \begin{code} +data HscResult + = HscOK ModDetails -- new details (HomeSymbolTable additions) + (Maybe ModIface) -- new iface (if any compilation was done) + (Maybe String) -- generated stub_h filename (in /tmp) + (Maybe String) -- generated stub_c filename (in /tmp) + (Maybe [UnlinkedIBind]) -- interpreted code, if any + PersistentCompilerState -- updated PCS + (Bag WarnMsg) -- warnings + + | HscErrs PersistentCompilerState -- updated PCS + (Bag ErrMsg) -- errors + (Bag WarnMsg) -- warnings + hscMain :: DynFlags -> ModSummary -- summary, including source filename @@ -258,7 +272,7 @@ initPersistentRenamerState :: PersistentRenamerState } initOrigNames :: FiniteMap (ModuleName,OccName) Name -initOrigNames = grab knownKeyNames `plusFM` grab wiredInNames +initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings) where grab names = foldl add emptyFM names add env name = addToFM env (moduleName (nameModule name), nameOccName name) name diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index a24813d..09a42c9 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -5,19 +5,23 @@ \begin{code} module HscTypes ( + Finder, ModuleLocation(..), + ModDetails(..), ModIface(..), GlobalSymbolTable, HomeSymbolTable, PackageSymbolTable, HomeIfaceTable, PackageIfaceTable, + VersionInfo(..), + TyThing(..), groupTyThings, TypeEnv, extendTypeEnv, lookupTypeEnv, lookupFixityEnv, - WhetherHasOrphans, ImportVersion, ExportItem, WhatsImported(..), + WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, DeprecationEnv, + IfaceInsts, IfaceRules, DeprecationEnv, GatedDecl, OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, AvailEnv, AvailInfo, GenAvailInfo(..), PersistentCompilerState(..), @@ -26,8 +30,6 @@ module HscTypes ( GlobalRdrEnv, RdrAvailInfo, - CompResult(..), HscResult(..), - -- Provenance Provenance(..), ImportReason(..), PrintUnqualified, pprNameProvenance, hasBetterProv @@ -36,44 +38,66 @@ module HscTypes ( #include "HsVersions.h" +import RdrName ( RdrNameEnv, emptyRdrEnv ) import Name ( Name, NameEnv, NamedThing, - unitNameEnv, extendNameEnv, plusNameEnv, + emptyNameEnv, unitNameEnv, extendNameEnv, plusNameEnv, lookupNameEnv, emptyNameEnv, getName, nameModule, nameSrcLoc ) -import Module ( Module, ModuleName, ModuleEnv, - extendModuleEnv, lookupModuleEnv ) -import Class ( Class ) +import NameSet ( NameSet ) import OccName ( OccName ) -import RdrName ( RdrNameEnv, emptyRdrEnv ) -import Outputable ( SDoc ) -import UniqFM ( UniqFM ) -import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM ) -import Bag ( Bag ) -import Id ( Id ) +import Module ( Module, ModuleName, ModuleEnv, + lookupModuleEnv ) +import VarSet ( TyVarSet ) import VarEnv ( IdEnv, emptyVarEnv ) -import BasicTypes ( Version, Fixity, defaultFixity ) +import Id ( Id ) +import Class ( Class ) import TyCon ( TyCon ) -import ErrUtils ( ErrMsg, WarnMsg ) -import CmLink ( Linkable ) -import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameHsDecl, - RdrNameDeprecation, RdrNameFixitySig ) -import InterpSyn ( UnlinkedIBind ) -import UniqSupply ( UniqSupply ) -import HsDecls ( DeprecTxt ) + +import BasicTypes ( Version, Fixity ) + +import HsSyn ( DeprecTxt ) +import RdrHsSyn ( RdrNameHsDecl ) +import RnHsSyn ( RenamedHsDecl ) + import CoreSyn ( CoreRule ) -import NameSet ( NameSet ) import Type ( Type ) -import Name ( emptyNameEnv ) -import VarSet ( TyVarSet ) -import Panic ( panic ) + +import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM ) +import Bag ( Bag ) +import UniqFM ( UniqFM ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) import Util ( thenCmp ) -import RnHsSyn ( RenamedHsDecl ) \end{code} %************************************************************************ %* * +\subsection{The Finder type} +%* * +%************************************************************************ + +\begin{code} +type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation)) + +data ModuleLocation + = ModuleLocation { + hs_file :: FilePath, + hi_file :: FilePath, + obj_file :: FilePath + } +\end{code} + +For a module in another package, the hs_file and obj_file +components of ModuleLocation are undefined. + +The locations specified by a ModuleLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModuleLocation still contains the path to +where the object file will reside if/when it is created. + + +%************************************************************************ +%* * \subsection{Symbol tables and Module details} %* * %************************************************************************ @@ -147,7 +171,6 @@ Simple lookups in the symbol table. \begin{code} lookupFixityEnv :: IfaceTable -> Name -> Maybe Fixity - -- Returns defaultFixity if there isn't an explicit fixity lookupFixityEnv tbl name = case lookupModuleEnv tbl (nameModule name) of Nothing -> Nothing @@ -225,10 +248,14 @@ but they are mostly elaborated elsewhere \begin{code} data VersionInfo = VersionInfo { - modVers :: Version, - fixVers :: Version, - ruleVers :: Version, - declVers :: NameEnv Version + vers_module :: Version, -- Changes when anything changes + vers_exports :: Version, -- Changes when export list changes + vers_rules :: Version, -- Changes when any rule changes + vers_decls :: NameEnv Version + -- Versions for "big" names only (not data constructors, class ops) + -- The version of an Id changes if its fixity changes + -- Ditto data constructors, class operations, except that the version of + -- the parent class/tycon changes } type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation @@ -268,14 +295,6 @@ type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contain %************************************************************************ \begin{code} -type ExportItem = (ModuleName, [RdrAvailInfo]) - -type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name) - -type ModVersionInfo = (Version, -- Version of the whole module - Version, -- Version number for all fixity decls together - Version) -- ...ditto all rules together - type WhetherHasOrphans = Bool -- An "orphan" is -- * an instance decl in a module other than the defn module for @@ -285,25 +304,31 @@ type WhetherHasOrphans = Bool type IsBootInterface = Bool +type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name) + data WhatsImported name = NothingAtAll -- The module is below us in the -- hierarchy, but we import nothing - | Everything Version -- The module version + | Everything Version -- Used for modules from other packages; + -- we record only the module's version number + + | Specifically + Version -- Module version + (Maybe Version) -- Export-list version, if we depend on it + [(name,Version)] -- List guaranteed non-empty + Version -- Rules version - | Specifically Version -- Module version - Version -- Fixity version - Version -- Rules version - [(name,Version)] -- List guaranteed non-empty deriving( Eq ) - -- 'Specifically' doesn't let you say "I imported f but none of the fixities in - -- the module". If you use anything in the module you get its fixity and rule version - -- So if the fixities or rules change, you'll recompile, even if you don't use either. + -- 'Specifically' doesn't let you say "I imported f but none of the rules in + -- the module". If you use anything in the module you get its rule version + -- So if the rules change, you'll recompile, even if you don't use them. -- This is easy to implement, and it's safer: you might not have used the rules last -- time round, but if someone has added a new rule you might need it this time - -- 'Everything' means there was a "module M" in - -- this module's export list, so we just have to go by M's version, - -- not the list of (name,version) pairs + -- The export list field is (Just v) if we depend on the export list: + -- we imported the module without saying exactly what we imported + -- We need to recompile if the module exports changes, because we might + -- now have a name clash in the importing module. \end{code} @@ -316,6 +341,8 @@ data WhatsImported name = NothingAtAll -- The module is below us in the \begin{code} data PersistentCompilerState = PCS { + pcs_PIT :: PackageIfaceTable, -- Domain = non-home-package modules + -- the mi_decls component is empty pcs_PST :: PackageSymbolTable, -- Domain = non-home-package modules -- except that the InstEnv components is empty pcs_insts :: InstEnv, -- The total InstEnv accumulated from all @@ -395,47 +422,6 @@ type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) %************************************************************************ %* * -\subsection{The result of compiling one module} -%* * -%************************************************************************ - -\begin{code} -data CompResult - = CompOK ModDetails -- new details (HST additions) - (Maybe (ModIface, Linkable)) - -- summary and code; Nothing => compilation not reqd - -- (old summary and code are still valid) - PersistentCompilerState -- updated PCS - (Bag WarnMsg) -- warnings - - | CompErrs PersistentCompilerState -- updated PCS - (Bag ErrMsg) -- errors - (Bag WarnMsg) -- warnings - - --- The driver sits between 'compile' and 'hscMain', translating calls --- to the former into calls to the latter, and results from the latter --- into results from the former. It does things like preprocessing --- the .hs file if necessary, and compiling up the .stub_c files to --- generate Linkables. - -data HscResult - = HscOK ModDetails -- new details (HomeSymbolTable additions) - (Maybe ModIface) -- new iface (if any compilation was done) - (Maybe String) -- generated stub_h filename (in /tmp) - (Maybe String) -- generated stub_c filename (in /tmp) - (Maybe [UnlinkedIBind]) -- interpreted code, if any - PersistentCompilerState -- updated PCS - (Bag WarnMsg) -- warnings - - | HscErrs PersistentCompilerState -- updated PCS - (Bag ErrMsg) -- errors - (Bag WarnMsg) -- warnings -\end{code} - - -%************************************************************************ -%* * \subsection{Provenance and export info} %* * %************************************************************************ diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs index adf6835..310c747 100644 --- a/ghc/compiler/main/TmpFiles.hs +++ b/ghc/compiler/main/TmpFiles.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: TmpFiles.hs,v 1.2 2000/10/11 11:54:58 simonmar Exp $ +-- $Id: TmpFiles.hs,v 1.3 2000/10/23 09:03:27 simonpj Exp $ -- -- Temporary file management -- @@ -21,7 +21,7 @@ import Config import Util -- hslibs -import Posix +-- import Posix commented out SLPJ import Exception import IOExts diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index d182ce1..6c69738 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -52,7 +52,7 @@ import FastString import StringBuffer import GlaExts import Ctype -import Char ( chr, ord ) +import Char ( ord ) import PrelRead ( readRational__ ) -- Glasgow non-std \end{code} diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 3c3e1ef..2726ef2 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -88,7 +88,6 @@ import HsPragmas import List ( nub ) import BasicTypes ( Boxity(..), RecFlag(..) ) import Class ( DefMeth (..) ) -import Outputable \end{code} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 9bbfc67..8c5ceb6 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -8,10 +8,8 @@ module PrelInfo ( module PrelNames, module MkId, - wiredInNames, -- Names of wired in things - wiredInThings, - maybeWiredInTyConName, - maybeWiredInIdName, + wiredInThings, -- Names of wired in things + wiredInThingEnv, -- Primop RdrNames eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, @@ -40,16 +38,12 @@ import MkId -- All of it, for re-export import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) import HscTypes ( TyThing(..) ) -import Id ( Id, idName ) -- others: -import RdrName ( RdrName ) -import Name ( Name, getName ) -import TyCon ( tyConDataConsIfAvailable, TyCon, tyConName ) +import Name ( getName, NameEnv, mkNameEnv ) +import TyCon ( tyConDataConsIfAvailable, TyCon ) import Class ( Class, classKey ) import Type ( funTyCon ) -import Bag -import BasicTypes ( Boxity(..) ) import Util ( isIn ) import Outputable ( ppr, pprPanic ) \end{code} @@ -68,7 +62,7 @@ wiredInThings :: [TyThing] wiredInThings = concat [ -- Wired in TyCons - map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) + concat (map wiredInTyConThings ([funTyCon] ++ primTyCons ++ wiredInTyCons)) -- Wired in Ids , map AnId wiredInIds @@ -77,28 +71,14 @@ wiredInThings , map (AnId . mkPrimOpId) allThePrimOps ] -wiredInNames :: [Name] -wiredInNames = [n | thing <- wiredInThings, n <- tyThingNames thing] - -tyThingNames :: TyThing -> [Name] -tyThingNames (AClass cl) = pprPanic "tyThingNames" (ppr cl) -- Not used -tyThingNames (AnId id) = [getName id] -tyThingNames (ATyCon tc) - = getName tc : [ getName n | dc <- tyConDataConsIfAvailable tc, - n <- [dataConId dc, dataConWrapId dc] ] - -- Synonyms return empty list of constructors - -maybeWiredInIdName :: Name -> Maybe Id -maybeWiredInIdName nm - = case filter ((== nm).idName) wiredInIds of - [] -> Nothing - (i:is) -> Just i - -maybeWiredInTyConName :: Name -> Maybe TyCon -maybeWiredInTyConName nm - = case filter ((== nm).tyConName) wiredInTyCons of - [] -> Nothing - (tc:tcs) -> Just tc +wiredInTyConThings :: TyCon -> [TyThing] +wiredInTyConThings tc + = ATyCon tc : [ AnId n | dc <- tyConDataConsIfAvailable tc, + n <- [dataConId dc, dataConWrapId dc] ] + -- Synonyms return empty list of constructors + +wiredInThingEnv :: NameEnv TyThing +wiredInThingEnv = mkNameEnv [ (getName thing, thing) | thing <- wiredInThings ] \end{code} We let a lot of "non-standard" values be visible, so that we can make diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 0d1b97f..adee169 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -310,7 +310,6 @@ trueVal = Var trueDataConId falseVal = Var falseDataConId mkIntVal i = Lit (mkMachInt i) mkWordVal w = Lit (mkMachWord w) -mkCharVal c = Lit (MachChar c) mkFloatVal f = Lit (convFloating (MachFloat f)) mkDoubleVal d = Lit (convFloating (MachDouble d)) \end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 04ed446..0fdd055 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -17,7 +17,6 @@ import RnHsSyn ( RenamedHsModule, RenamedHsDecl, import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad -import Finder ( Finder ) import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnDecl ) import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, @@ -68,7 +67,7 @@ import SrcLoc ( noSrcLoc ) import Maybes ( maybeToBool, expectJust ) import Outputable import IO ( openFile, IOMode(..) ) -import HscTypes ( PersistentCompilerState, HomeSymbolTable, GlobalRdrEnv, +import HscTypes ( Finder, PersistentCompilerState, HomeSymbolTable, GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo, Provenance(..), ImportReason(..) ) @@ -84,13 +83,16 @@ type FixityEnv = LocalFixityEnv \begin{code} type RenameResult = ( PersistentCompilerState - , ModIface -- The mi_decls in here include - -- ones imported from packages too + , ModIface ) renameModule :: DynFlags -> Finder -> PersistentCompilerState -> HomeSymbolTable - -> RdrNameHsModule -> IO (Maybe RenameResult) + -> RdrNameHsModule + -> IO (PersistentCompilerState, Maybe ModIface) + -- The mi_decls in the ModIface include + -- ones imported from packages too + renameModule dflags finder old_pcs hst this_mod@(HsModule mod_name vers exports imports local_decls _ loc) = -- Initialise the renamer monad @@ -113,7 +115,7 @@ renameModule dflags finder old_pcs hst \end{code} \begin{code} -rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ()) +rename :: RdrNameHsModule -> RnMG (Maybe ModIface, IO ()) rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> @@ -165,7 +167,7 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l else -- GENERATE THE VERSION/USAGE INFO - mkImportExportInfo mod_name export_avails exports `thenRn` \ (my_exports, my_usages) -> + mkImportExportInfo mod_name export_avails imports `thenRn` \ (my_exports, my_usages) -> -- RETURN THE RENAMED MODULE getNameSupplyRn `thenRn` \ name_supply -> @@ -187,33 +189,20 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l -- (a) defined in this module -- (b) exported exported_fixities - = [ FixitySig (toRdrName name) fixity loc - | FixitySig name fixity loc <- nameEnvElts local_fixity_env, - isUserExportedName name - ] - ------ HERE - new_iface = ParsedIface { pi_mod = this_module - , pi_vers = initialVersion - , pi_orphan = any isOrphanDecl rn_local_decls - , pi_exports = my_exports - , pi_usages = my_usages - , pi_fixity = (initialVersion, exported_fixities) - , pi_deprecs = my_deprecs - -- These ones get filled in later - , pi_insts = [], pi_decls = [] - , pi_rules = (initialVersion, []) - } - - renamed_module = HsModule mod_name vers - trashed_exports trashed_imports - (rn_local_decls ++ rn_imp_decls) - mod_deprec - loc - - result = (this_module, renamed_module, - old_iface, new_iface, - name_supply, local_fixity_env, - direct_import_mods) + = mkNameEnv [ (name, fixity) + | FixitySig name fixity loc <- nameEnvElts local_fixity_env, + isUserExportedName name + ] + + mod_iface = ModIface { mi_module = this_module + mi_version = panic "mi_version: not filled in yet", + mi_orphan = any isOrphanDecl rn_local_decls, + mi_exports = my_exports, + mi_usages = my_usages, + mi_fixity = exported_fixities) + mi_deprecs = my_deprecs + mi_decls = rn_local_decls ++ rn_imp_decls + } in -- REPORT UNUSED NAMES, AND DEBUG DUMP @@ -222,7 +211,7 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec l export_avails source_fvs rn_imp_decls `thenRn_` - returnRn (Just result, dump_action) } + returnRn (Just mod_iface, dump_action) } where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 0d99885..e9efa34 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -13,16 +13,15 @@ import RdrHsSyn ( RdrNameIE ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, mkRdrUnqual, qualifyRdrName ) -import HsTypes ( hsTyVarName, hsTyVarNames, replaceTyVarName ) +import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, Avails, AvailEnv, + ImportReason(..), GlobalRdrEnv, AvailEnv, AvailInfo, GenAvailInfo(..), RdrAvailInfo ) import RnMonad import Name ( Name, NamedThing(..), getSrcLoc, mkLocalName, mkImportedLocalName, mkGlobalName, - mkIPName, isLocallyDefined, - nameOccName, nameModule, + mkIPName, nameOccName, nameModule, extendNameEnv_C, plusNameEnv_C, nameEnvElts, setNameModuleAndLoc ) @@ -35,7 +34,7 @@ import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) -import Util ( thenCmp, sortLt ) +import Util ( sortLt ) import List ( nub ) import PrelNames ( mkUnboundName ) import CmdLineOpts diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 07f07cd..e637ea6 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -5,22 +5,18 @@ \begin{code} module RnIfaces -#if 0 ( findAndReadIface, - getInterfaceExports, getDeferredDecls, + getInterfaceExports, getImportedInstDecls, getImportedRules, lookupFixityRn, loadHomeInterface, importDecl, ImportDeclResult(..), recordLocalSlurps, loadBuiltinRules, mkImportExportInfo, getSlurped, - checkModUsage, outOfDate, upToDate, - getDeclBinders, getDeclSysBinders, removeContext -- removeContext probably belongs somewhere else ) -#endif where #include "HsVersions.h" @@ -34,7 +30,7 @@ import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), ) import HsImpExp ( ieNames ) import CoreSyn ( CoreRule ) -import BasicTypes ( Version, NewOrData(..) ) +import BasicTypes ( Version, defaultFixity ) import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameRuleDecl, RdrNameDeprecation, RdrNameIE, extractHsTyRdrNames @@ -45,19 +41,19 @@ import ParseIface ( parseIface, IfaceStuff(..) ) import Name ( Name {-instance NamedThing-}, nameOccName, nameModule, isLocallyDefined, - {-isWiredInName, -} NamedThing(..), - elemNameEnv, extendNameEnv + NamedThing(..), + mkNameEnv, elemNameEnv, extendNameEnv ) -import Module ( Module, mkVanillaModule, +import Module ( Module, moduleName, isModuleInThisPackage, ModuleName, WhereFrom(..), + extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName ) import RdrName ( RdrName, rdrNameOcc ) import NameSet import SrcLoc ( mkSrcLoc, SrcLoc ) -import PrelInfo ( cCallishTyKeys ) -import Maybes ( maybeToBool ) -import Unique ( Uniquable(..) ) +import PrelInfo ( cCallishTyKeys, wiredInThingEnv ) +import Maybes ( maybeToBool, orElse ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) @@ -69,30 +65,6 @@ import Bag import HscTypes import List ( nub ) - -#if 1 -import Panic ( panic ) -lookupFixityRn = panic "lookupFixityRn" -findAndReadIface = panic "findAndReadIface" -getInterfaceExports = panic "getInterfaceExports" -getDeclBinders = panic "getDeclBinders" -recordLocalSlurps = panic "recordLocalSlurps" -checkModUsage = panic "checkModUsage" -outOfDate = panic "outOfDate" -getSlurped = panic "getSlurped" -removeContext = panic "removeContext" -loadBuiltinRules = panic "loadBuiltinRules" -getDeferredDecls = panic "getDeferredDecls" -data ImportDeclResult - = AlreadySlurped - | WiredIn - | Deferred - | HereItIs (Module, RdrNameHsDecl) -getImportedInstDecls = panic "getImportedInstDecls" -importDecl = panic "importDecl" -mkImportExportInfo = panic "mkImportExportInfo" -getImportedRules = panic "getImportedRules" -#else \end{code} @@ -111,7 +83,7 @@ loadOrphanModules :: [ModuleName] -> RnM d () loadOrphanModules mods | null mods = returnRn () | otherwise = traceRn (text "Loading orphan modules:" <+> - fsep (map mods)) `thenRn_` + fsep (map ppr mods)) `thenRn_` mapRn_ load mods `thenRn_` returnRn () where @@ -167,7 +139,7 @@ tryLoadInterface doc_str mod_name from (warnRedundantSourceImport mod_name) `thenRn_` -- READ THE MODULE IN - findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ read_resultb -> + findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ read_result -> case read_result of { Left err -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again @@ -199,14 +171,14 @@ tryLoadInterface doc_str mod_name from loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> loadFixDecls mod_name (pi_fixity iface) `thenRn` \ (fix_vers, fix_env) -> - foldlRn (loadDeprec mod) emptyDeprecEnv (pi_deprecs iface) `thenRn` \ deprec_env -> + foldlRn (loadDeprec mod) emptyNameEnv (pi_deprecs iface) `thenRn` \ deprec_env -> foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> loadExports (pi_exports iface) `thenRn` \ avails -> let version = VersionInfo { modVers = pi_vers iface, fixVers = fix_vers, ruleVers = rule_vers, - declVers = decl_vers } + declVers = decls_vers } -- For an explicit user import, add to mod_map info about -- the things the imported module depends on, extracted @@ -214,13 +186,18 @@ tryLoadInterface doc_str mod_name from mod_map1 = case from of ImportByUser -> addModDeps mod (pi_usages iface) mod_map other -> mod_map - mod_map2 = addToFM mod_map1 mod_name (pi_orphan iface, hi_boot_file, True) - - -- Now add info about this module to the PST - new_pit = extendModuleEnv pit mod mod_iface - mod_iface = ModIface { mdModule = mod, mvVersion = version, - mdExports = avails, - mdFixEnv = fix_env, mdDeprecEnv = deprec_env } + mod_map2 = addToFM mod_map1 mod_name (has_orphans, hi_boot_file, True) + + -- Now add info about this module to the PIT + has_orphans = pi_orphan iface + new_pit = extendModuleEnv (iPIT ifaces) mod mod_iface + mod_iface = ModIface { mi_module = mod, mi_version = version, + mi_exports = avails, mi_orphan = has_orphans, + mi_fixities = fix_env, mi_deprecs = deprec_env, + mi_usages = [], -- Will be filled in later + mi_decls = panic "No mi_decls in PIT", + mi_globals = panic "No mi_globals in PIT" + } new_ifaces = ifaces { iPIT = new_pit, iDecls = new_decls, @@ -237,7 +214,7 @@ tryLoadInterface doc_str mod_name from -- import decls in the interface file ----------------------------------------------------- -addModDeps :: Module -> PackageSymbolTable -> [ImportVersion a] +addModDeps :: Module -> [ImportVersion a] -> ImportedModuleInfo -> ImportedModuleInfo -- (addModDeps M ivs deps) -- We are importing module M, and M.hi contains 'import' decls given by ivs @@ -247,7 +224,7 @@ addModDeps mod new_deps mod_deps -- Don't record dependencies when importing a module from another package -- Except for its descendents which contain orphans, -- and in that case, forget about the boot indicator - filtered_new_deps :: (ModuleName, (WhetherHasOrphans, IsBootInterface)) + filtered_new_deps :: [(ModuleName, (WhetherHasOrphans, IsBootInterface))] filtered_new_deps | isModuleInThisPackage mod = [ (imp_mod, (has_orphans, is_boot, False)) @@ -384,15 +361,12 @@ loadDecl mod (version_map, decls_map) (version, decl) ----------------------------------------------------- loadFixDecls mod_name (version, decls) - | null decls = returnRn (version, emptyNameEnv) - - | otherwise = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> returnRn (version, mkNameEnv to_add) loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> - returnRn (name, FixitySig name fixity loc) + returnRn (name, fixity) ----------------------------------------------------- @@ -485,111 +459,6 @@ loadDeprec mod deprec_env (Deprecation ie txt _) \end{code} -%******************************************************** -%* * -\subsection{Checking usage information} -%* * -%******************************************************** - -\begin{code} -upToDate = True -outOfDate = False - -checkModUsage :: [ImportVersion OccName] -> RnMG Bool --- Given the usage information extracted from the old --- M.hi file for the module being compiled, figure out --- whether M needs to be recompiled. - -checkModUsage [] = returnRn upToDate -- Yes! Everything is up to date! - -checkModUsage ((mod_name, _, _, NothingAtAll) : rest) - -- If CurrentModule.hi contains - -- import Foo :: ; - -- then that simply records that Foo lies below CurrentModule in the - -- hierarchy, but CurrentModule doesn't depend in any way on Foo. - -- In this case we don't even want to open Foo's interface. - = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_` - checkModUsage rest -- This one's ok, so check the rest - -checkModUsage ((mod_name, _, _, whats_imported) : rest) - = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> - case maybe_err of { - Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), - ppr mod_name]) ; - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain -- it might just be that - -- the current module doesn't need that import and it's been deleted - - Nothing -> - let - (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _) - = case lookupFM (iImpModInfo ifaces) mod_name of - Just (_, _, Just stuff) -> stuff - - old_mod_vers = case whats_imported of - Everything v -> v - Specifically v _ _ _ -> v - -- NothingAtAll case dealt with by previous eqn for checkModUsage - in - -- If the module version hasn't changed, just move on - if new_mod_vers == old_mod_vers then - traceRn (sep [ptext SLIT("Module version unchanged:"), ppr mod_name]) - `thenRn_` checkModUsage rest - else - traceRn (sep [ptext SLIT("Module version has changed:"), ppr mod_name]) - `thenRn_` - -- Module version changed, so check entities inside - - -- If the usage info wants to say "I imported everything from this module" - -- it does so by making whats_imported equal to Everything - -- In that case, we must recompile - case whats_imported of { -- NothingAtAll dealt with earlier - - Everything _ - -> out_of_date (ptext SLIT("...and I needed the whole module")) ; - - Specifically _ old_fix_vers old_rule_vers old_local_vers -> - - if old_fix_vers /= new_fix_vers then - out_of_date (ptext SLIT("Fixities changed")) - else if old_rule_vers /= new_rule_vers then - out_of_date (ptext SLIT("Rules changed")) - else - -- Non-empty usage list, so check item by item - checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date -> - if up_to_date then - traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` - checkModUsage rest -- This one's ok, so check the rest - else - returnRn outOfDate -- This one failed, so just bail out now - }} - where - doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] - - -checkEntityUsage mod decls [] - = returnRn upToDate -- Yes! All up to date! - -checkEntityUsage mod decls ((occ_name,old_vers) : rest) - = newGlobalName mod occ_name `thenRn` \ name -> - case lookupNameEnv decls name of - - Nothing -> -- We used it before, but it ain't there now - out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) - - Just (new_vers,_,_,_) -- It's there, but is it up to date? - | new_vers == old_vers - -- Up to date, so check the rest - -> checkEntityUsage mod decls rest - - | otherwise - -- Out of date, so bale out - -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) - -out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate -\end{code} - - %********************************************************* %* * \subsection{Getting in a declaration} @@ -606,22 +475,28 @@ data ImportDeclResult | HereItIs (Module, RdrNameHsDecl) importDecl name - = getIfacesRn `thenRn` \ ifaces -> - getHomeSymbolTableRn `thenRn` \ hst -> - if name `elemNameSet` iSlurp ifaces - || inTypeEnv (iPST ifaces) name - || inTypeEnv hst name - then -- Already dealt with + = -- Check if it was loaded before beginning this module + checkAlreadyAvailable name `thenRn` \ done -> + if done then + returnRn AlreadySlurped + else + + -- Check if we slurped it in while compiling this module + getIfacesRn `thenRn` \ ifaces -> + if name `elemNameSet` iSlurp ifaces then returnRn AlreadySlurped + else - else if isLocallyDefined name then -- Don't bring in decls from - -- the renamed module's own interface file + -- Don't slurp in decls from this module's own interface file + -- (Indeed, this shouldn't happen.) + if isLocallyDefined name then addWarnRn (importDeclWarn name) `thenRn_` returnRn AlreadySlurped + else - else if isWiredInName name then - -- When we find a wired-in name we must load its - -- home module so that we find any instance decls therein + -- When we find a wired-in name we must load its home + -- module so that we find any instance decls lurking therein + if name `elemNameEnv` wiredInThingEnv then loadHomeInterface doc name `thenRn_` returnRn WiredIn @@ -635,6 +510,7 @@ getNonWiredInDecl needed_name loadHomeInterface doc_str needed_name `thenRn` \ ifaces -> case lookupNameEnv (iDecls ifaces) needed_name of +{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _))) -- This case deals with deferred import of algebraic data types @@ -650,28 +526,31 @@ getNonWiredInDecl needed_name -- Never defer ccall types; we have to unbox them, -- and importing them does no harm - -> -- OK, so we're importing a deferrable data type - if needed_name == tycon_name then - -- The needed_name is the TyCon of a data type decl + + -> -- OK, so we're importing a deferrable data type + if needed_name == tycon_name + -- The needed_name is the TyCon of a data type decl -- Record that it's slurped, put it in the deferred set -- and don't return a declaration at all setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces `addOneToNameSet` tycon_name}) version (AvailTC needed_name [needed_name])) `thenRn_` returnRn Deferred + else - -- The needed name is a constructor of a data type decl, + -- The needed name is a constructor of a data type decl, -- getting a constructor, so remove the TyCon from the deferred set -- (if it's there) and return the full declaration - setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces + setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces `delFromNameSet` tycon_name}) version avail) `thenRn_` - returnRn (HereItIs decl) + returnRn (HereItIs decl) where tycon_name = availName avail +-} - Just (version,avail,_,decl) - -> setIfacesRn (recordSlurp ifaces version avail) `thenRn_` + Just (avail,_,decl) + -> setIfacesRn (recordSlurp ifaces avail) `thenRn_` returnRn (HereItIs decl) Nothing @@ -680,6 +559,7 @@ getNonWiredInDecl needed_name where doc_str = ptext SLIT("need decl for") <+> ppr needed_name +{- OMIT FOR NOW getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)] getDeferredDecls = getIfacesRn `thenRn` \ ifaces -> @@ -691,6 +571,7 @@ getDeferredDecls in traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_` returnRn (map get_abstract_decl deferred_names) +-} \end{code} @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. @@ -726,18 +607,17 @@ that we know just what instances to bring into scope. \begin{code} getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, Avails) getInterfaceExports mod_name from - = getHomeSymbolTableRn `thenRn` \ hst -> - case lookupModuleEnvByName hst mod_name of { - Just mds -> returnRn (mdModule mds, mdExports mds) ; - Nothing -> pprPanic "getInterfaceExports" (ppr mod_name) - --- I think this is what it _used_ to say. JRS, 001017 --- loadInterface doc_str mod_name from `thenRn` \ ifaces -> --- case lookupModuleEnv (iPST ifaces) mod_name of --- Just mds -> returnRn (mdModule mod, mdExports mds) --- -- loadInterface always puts something in the map --- -- even if it's a fake - + = getHomeIfaceTableRn `thenRn` \ hit -> + case lookupModuleEnvByName hit mod_name of { + Just mi -> returnRn (mi_module mi, mi_exports mi) ; + Nothing -> + + loadInterface doc_str mod_name from `thenRn` \ ifaces -> + case lookupModuleEnvByName (iPIT ifaces) mod_name of + Just mi -> returnRn (mi_module mi, mi_exports mi) ; + -- loadInterface always puts something in the map + -- even if it's a fake + Nothing -> pprPanic "getInterfaceExports" (ppr mod_name) } where doc_str = sep [ppr mod_name, ptext SLIT("is directly imported")] @@ -758,7 +638,7 @@ getImportedInstDecls gates getIfacesRn `thenRn` \ ifaces -> let orphan_mods = - [mod | (mod, (True, _, Nothing)) <- fmToList (iImpModInfo ifaces)] + [mod | (mod, (True, _, False)) <- fmToList (iImpModInfo ifaces)] in loadOrphanModules orphan_mods `thenRn_` @@ -830,13 +710,13 @@ lookupFixityRn name -- right away (after all, it's possible that nothing from B will be used). -- When we come across a use of 'f', we need to know its fixity, and it's then, -- and only then, that we load B.hi. That is what's happening here. - = getHomeSymbolTableRn `thenRn` \ hst -> + = getHomeIfaceTableRn `thenRn` \ hst -> case lookupFixityEnv hst name of { Just fixity -> returnRn fixity ; Nothing -> loadHomeInterface doc name `thenRn` \ ifaces -> - returnRn (lookupFixityEnv (iPST ifaces) name `orElse` defaultFixity) + returnRn (lookupFixityEnv (iPIT ifaces) name `orElse` defaultFixity) } where doc = ptext SLIT("Checking fixity for") <+> ppr name @@ -903,29 +783,31 @@ So we'll get an early bale-out when compiling A if B's version changes. \begin{code} mkImportExportInfo :: ModuleName -- Name of this module -> Avails -- Info about exports - -> Maybe [RdrNameIE] -- The export header + -> [ImportDecl n] -- The import decls -> RnMG ([ExportItem], -- Export info for iface file; sorted - [ImportVersion OccName]) -- Import info for iface file; sorted + [ImportVersion Name]) -- Import info for iface file; sorted -- Both results are sorted into canonical order to -- reduce needless wobbling of interface files mkImportExportInfo this_mod export_avails exports = getIfacesRn `thenRn` \ ifaces -> let - export_all_mods = case exports of - Nothing -> [] - Just es -> [mod | IEModuleContents mod <- es, - mod /= this_mod] + import_all_mods :: [ModuleName] + -- Modules where we imported all the names + -- (apart from hiding some, perhaps) + import_all_mods = nub [ m | ImportDecl m _ _ _ imp_list _ <- imports ] + + import_all (Just (False, _)) = False -- Imports are specified explicitly + import_all other = True -- Everything is imported mod_map = iImpModInfo ifaces imp_names = iVSlurp ifaces -- mv_map groups together all the things imported from a particular module. - mv_map :: FiniteMap ModuleName [(OccName,Version)] + mv_map :: ModuleEnv [Name] mv_map = foldr add_mv emptyFM imp_names - add_mv (name, version) mv_map = addItem mv_map (moduleName (nameModule name)) - (nameOccName name, version) + add_mv (name, version) mv_map = addItem mv_map (nameModule name) name -- Build the result list by adding info for each module. -- For (a) a library module, we don't record it at all unless it contains orphans @@ -943,82 +825,71 @@ mkImportExportInfo this_mod export_avails exports -- whether something is a boot file along with the usage info for it, but -- I can't be bothered just now. - mk_imp_info mod_name (has_orphans, is_boot, contents) so_far + mk_imp_info mod_name (has_orphans, is_boot, opened) so_far | mod_name == this_mod -- Check if M appears in the set of modules 'below' M -- This seems like a convenient place to check = WARN( not is_boot, ptext SLIT("Wierd:") <+> ppr this_mod <+> ptext SLIT("imports itself (perhaps indirectly)") ) so_far - | otherwise - = let - go_for_it exports = (mod_name, has_orphans, is_boot, exports) - : so_far - in - case contents of - Nothing -> -- We didn't even open the interface - -- This happens when a module, Foo, that we explicitly imported has + | not opened -- We didn't even open the interface + -> -- This happens when a module, Foo, that we explicitly imported has -- 'import Baz' in its interface file, recording that Baz is below -- Foo in the module dependency hierarchy. We want to propagate this -- information. The Nothing says that we didn't even open the interface -- file but we must still propagate the dependeny info. -- The module in question must be a local module (in the same package) - go_for_it NothingAtAll + go_for_it NothingAtAll + - Just (mod, mod_vers, fix_vers, rule_vers, how_imported, _) - | is_sys_import && is_lib_module && not has_orphans - -> so_far + | is_lib_module && not has_orphans + -> so_far - | is_lib_module -- Record the module but not detailed - || mod_name `elem` export_all_mods -- version information for the imports - -> go_for_it (Everything mod_vers) - - | otherwise - -> case lookupFM mv_map mod_name of - Just whats_imported -> go_for_it (Specifically mod_vers fix_vers rule_vers - (sortImport whats_imported)) - Nothing -> go_for_it NothingAtAll - -- This happens if you have - -- import Foo - -- but don't actually *use* anything from Foo - -- In which case record an empty dependency list - where - is_lib_module = not (isModuleInThisPackage mod) - is_sys_import = case how_imported of - ImportBySystem -> True - other -> False - + | is_lib_module -- Record the module version only + -> go_for_it (Everything mod_vers) + | otherwise + -> go_for_it (mk_whats_imported mod mod_vers) + + where + + where + go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far + mod_iface = lookupIface hit pit mod_name + mod = mi_module mod_iface + is_lib_module = not (isModuleInThisPackage mod) + version_info = mi_version mod_iface + version_env = vers_decls version_info + + whats_imported = Specifically mod_vers export_vers import_items + (vers_rules version_info) + + import_items = [(n,v) | n <- lookupWithDefaultModuleEnv mv_map [] mod, + let v = lookupNameEnv version_env `orElse` + pprPanic "mk_whats_imported" (ppr n) + ] + export_vers | moduleName mod `elem` import_all_mods = Just (vers_exports version_info) + | otherwise = Nothing + import_info = foldFM mk_imp_info [] mod_map -- Sort exports into groups by module - export_fm :: FiniteMap ModuleName [RdrAvailInfo] + export_fm :: FiniteMap Module [RdrAvailInfo] export_fm = foldr insert emptyFM export_avails - insert avail efm = addItem efm (moduleName (nameModule (availName avail))) - (rdrAvailInfo avail) + insert avail efm = addItem efm (nameModule (availName avail)) + avail - export_info = [(m, sortExport as) | (m,as) <- fmToList export_fm] + export_info = fmToList export_fm in traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map))) `thenRn_` returnRn (export_info, import_info) -addItem :: FiniteMap ModuleName [a] -> ModuleName -> a -> FiniteMap ModuleName [a] -addItem fm mod x = addToFM_C add_item fm mod [x] +addItem :: ModuleEnv [a] -> Module -> a -> ModuleEnv [a] +addItem fm mod x = plusModuleEnv_C add_item fm mod [x] where add_item xs _ = x:xs - -sortImport :: [(OccName,Version)] -> [(OccName,Version)] - -- Make the usage lists appear in canonical order -sortImport vs = sortLt lt vs - where - lt (n1,v1) (n2,v2) = n1 < n2 - -sortExport :: [RdrAvailInfo] -> [RdrAvailInfo] -sortExport as = sortLt lt as - where - lt a1 a2 = availName a1 < availName a2 \end{code} \begin{code} @@ -1027,10 +898,10 @@ getSlurped returnRn (iSlurp ifaces) recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names }) - version avail + avail = let new_slurped_names = addAvailToNameSet slurped_names avail - new_imp_names = (availName avail, version) : imp_names + new_imp_names = availName avail : imp_names in ifaces { iSlurp = new_slurped_names, iVSlurp = new_imp_names } @@ -1168,18 +1039,17 @@ findAndReadIface doc_str mod_name hi_boot_file -- one for 'normal' ones, the other for .hi-boot files, -- hence the need to signal which kind we're interested. - getFinderRn `thenRn` \ finder -> - ioToRn (findModule finder mod_name) `thenRn` \ maybe_module -> + getFinderRn `thenRn` \ finder -> + ioToRnM (finder mod_name) `thenRn` \ maybe_found -> - case maybe_module of - Just mod | hi_boot_file, Just fpath <- moduleHiBootFile mod - -> readIface mod fpath - | not hi_boot_file, Just fpath <- moduleHiFile mod - -> readIface mod fpath + case maybe_found of + Just (mod,locn) + | hi_boot_file -> readIface mod (hi_file locn ++ "-hi-boot") + | otherwise -> readIface mod (hi_file locn) -- Can't find it other -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (Left (noIfaceErr finder mod_name hi_boot_file)) + returnRn (Left (noIfaceErr mod_name hi_boot_file)) where trace_msg = sep [hsep [ptext SLIT("Reading"), @@ -1206,11 +1076,11 @@ readIface wanted_mod file_path glasgow_exts = 1#, loc = mkSrcLoc (mkFastString file_path) 1 } of POk _ (PIface iface) -> - warnCheckRn (moduleName wanted_mod == read_mod) + warnCheckRn (wanted_mod == read_mod) (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_` - returnRn (Right (mod, iface)) + returnRn (Right (wanted_mod, iface)) where - read_mod = moduleName (pi_mod iface) + read_mod = pi_mod iface PFailed err -> bale_out err parse_result -> bale_out empty @@ -1231,17 +1101,11 @@ readIface wanted_mod file_path %********************************************************* \begin{code} -noIfaceErr mod_name boot_file search_path - = vcat [ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name), - ptext SLIT("in the directories") <+> - -- \& to avoid cpp interpreting this string as a - -- comment starter with a pre-4.06 mkdependHS --SDM - vcat [ text dir <> text "/\&*" <> pp_suffix suffix - | (dir,suffix) <- search_path] - ] - where - pp_suffix suffix | boot_file = ptext SLIT(".hi-boot") - | otherwise = text suffix +noIfaceErr mod_name boot_file + = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) + -- We used to print the search path, but we can't do that + -- now, becuase it's hidden inside the finder. + -- Maybe the finder should expose more functions. badIfaceFile file err = vcat [ptext SLIT("Bad interface file:") <+> text file, @@ -1273,4 +1137,3 @@ hiModuleNameMismatchWarn requested_mod read_mod = ] \end{code} -#endif /* TEMP DEBUG HACK! */ \ No newline at end of file diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 8f5270d..a86298c 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -35,6 +35,15 @@ import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig ) +import HscTypes ( Finder, + AvailEnv, lookupTypeEnv, + OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, + WhetherHasOrphans, ImportVersion, + PersistentRenamerState(..), IsBootInterface, Avails, + DeclsMap, IfaceInsts, IfaceRules, + HomeSymbolTable, PackageSymbolTable, + PersistentCompilerState(..), GlobalRdrEnv, + HomeIfaceTable, PackageIfaceTable ) import BasicTypes ( Version, defaultFixity ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message @@ -49,25 +58,17 @@ import Name ( Name, OccName, NamedThing(..), getSrcLoc, NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) -import Module ( Module, ModuleName, WhereFrom, moduleName ) +import Module ( Module, ModuleName ) import NameSet import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import SrcLoc ( SrcLoc, generatedSrcLoc ) import Unique ( Unique ) -import FiniteMap ( FiniteMap, emptyFM, listToFM, plusFM ) -import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) +import FiniteMap ( FiniteMap, emptyFM ) +import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable -import Finder ( Finder ) import PrelNames ( mkUnboundName ) -import HscTypes ( GlobalSymbolTable, AvailEnv, - OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, - WhetherHasOrphans, ImportVersion, ExportItem, - PersistentRenamerState(..), IsBootInterface, Avails, - DeclsMap, IfaceInsts, IfaceRules, DeprecationEnv, - HomeSymbolTable, PackageSymbolTable, - PersistentCompilerState(..), GlobalRdrEnv, - HomeIfaceTable, PackageIfaceTable ) +import Maybes ( maybeToBool, seqMaybe ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -119,8 +120,13 @@ data RnDown rn_finder :: Finder, rn_dflags :: DynFlags, + rn_hit :: HomeIfaceTable, - rn_done :: Name -> Bool, -- available before compiling this module? + rn_done :: Name -> Bool, -- Tells what things (both in the + -- home package and other packages) + -- were already available (i.e. in + -- the relevant SymbolTable) before + -- compiling this module rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), @@ -186,6 +192,7 @@ type ExportAvails = (FiniteMap ModuleName Avails, %=================================================== \begin{code} +type ExportItem = (ModuleName, [RdrAvailInfo]) data ParsedIface = ParsedIface { @@ -251,11 +258,14 @@ data Ifaces = Ifaces { -- All the names (whether "big" or "small", whether wired-in or not, -- whether locally defined or not) that have been slurped in so far. - iVSlurp :: [(Name,Version)] + iVSlurp :: [Name] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined -- names that have been slurped in so far, with their versions. -- This is used to generate the "usage" information for this module. -- Subset of the previous field. + -- It's worth keeping separately, because there's no very easy + -- way to distinguish the "big" names from the "non-big" ones. + -- But this is a decision we might want to revisit. } type ImportedModuleInfo = FiniteMap ModuleName @@ -274,15 +284,18 @@ type IsLoaded = Bool initRn :: DynFlags -> Finder -> HomeIfaceTable + -> HomeSymbolTable -> PersistentCompilerState -> Module -> SrcLoc -> RnMG t -> IO (t, PersistentCompilerState, (Bag WarnMsg, Bag ErrMsg)) -initRn dflags finder hit pcs mod loc do_rn +initRn dflags finder hit hst pcs mod loc do_rn = do let prs = pcs_PRS pcs + let pst = pcs_PST pcs + uniqs <- mkSplitUniqSupply 'r' names_var <- newIORef (uniqs, origNames (prsOrig prs), origIParam (prsOrig prs)) @@ -294,6 +307,7 @@ initRn dflags finder hit pcs mod loc do_rn rn_finder = finder, rn_dflags = dflags, rn_hit = hit, + rn_done = is_done hst pst, rn_ns = names_var, rn_errs = errs_var, @@ -312,15 +326,23 @@ initRn dflags finder hit pcs mod loc do_rn prsDecls = iDecls new_ifaces, prsInsts = iInsts new_ifaces, prsRules = iRules new_ifaces } - let new_pcs = pcs { pcs_PST = iPST new_ifaces, + let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, pcs_PRS = new_prs } return (res, new_pcs, (warns, errs)) +is_done :: HomeSymbolTable -> PackageSymbolTable -> Name -> Bool +-- Returns True iff the name is in either symbol table +is_done hst pst n = maybeToBool (lookupTypeEnv pst n `seqMaybe` lookupTypeEnv hst n) + +lookupIface :: HomeInterfaceTable -> PackageInterfaceTable -> ModuleName -> ModIface +lookupIface hit pit mod = lookupModuleEnvByName hit mod `orElse` + lookupModuleEnvByName pit mod `orElse` + pprPanic "lookupIface" (ppr mod) initIfaces :: PersistentCompilerState -> Ifaces -initIfaces (PCS { pcs_PST = pst, pcs_PRS = prs }) - = Ifaces { iPST = pst, +initIfaces (PCS { pcs_PIT = pit, pcs_PRS = prs }) + = Ifaces { iPIT = pit, iDecls = prsDecls prs, iInsts = prsInsts prs, iRules = prsRules prs, @@ -379,7 +401,8 @@ renameSourceCode dflags mod prs m rn_loc = generatedSrcLoc, rn_ns = names_var, rn_errs = errs_var, rn_mod = mod, - rn_ifaces = panic "rnameSourceCode: rn_ifaces" -- Not required + rn_ifaces = panic "rnameSourceCode: rn_ifaces", -- Not required + rn_finder = panic "rnameSourceCode: rn_finder" -- Not required } s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc @@ -559,6 +582,9 @@ getFinderRn down l_down = return (rn_finder down) getHomeIfaceTableRn :: RnM d HomeIfaceTable getHomeIfaceTableRn down l_down = return (rn_hit down) + +checkAlreadyAvailable :: Name -> RnM d Bool +checkAlreadyAvailable name down l_down = return (rn_done down name) \end{code} %================ diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 4b17019..00ba87c 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -169,35 +169,6 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) \end{code} \begin{code} -checkEarlyExit mod_name - = traceRn (text "Considering whether compilation is required...") `thenRn_` - - -- Read the old interface file, if any, for the module being compiled - findAndReadIface doc_str mod_name False {- Not hi-boot -} `thenRn` \ maybe_iface -> - - -- CHECK WHETHER WE HAVE IT ALREADY - case maybe_iface of - Left err -> -- Old interface file not found, so we'd better bail out - traceRn (vcat [ptext SLIT("No old interface file for") <+> ppr mod_name, - err]) `thenRn_` - returnRn (outOfDate, Nothing) - - Right iface - | panic "checkEarlyExit: ???: not opt_SourceUnchanged" - -> -- Source code changed - traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` - returnRn (False, Just iface) - - | otherwise - -> -- Source code unchanged and no errors yet... carry on - checkModUsage (pi_usages iface) `thenRn` \ up_to_date -> - returnRn (up_to_date, Just iface) - where - -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), ppr mod_name] -\end{code} - -\begin{code} importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier -> RdrNameImportDecl -> RnMG (GlobalRdrEnv, diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 826f6e1..fbbf6b5 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -830,8 +830,6 @@ addOneOcc usage id info emptyDetails = (emptyVarEnv :: UsageDetails) -unitDetails id info = (unitVarEnv id info :: UsageDetails) - usedIn :: Id -> UsageDetails -> Bool v `usedIn` details = isExportedId v || v `elemVarEnv` details diff --git a/ghc/compiler/stgSyn/StgInterp.lhs b/ghc/compiler/stgSyn/StgInterp.lhs index 08ef24d..1ccbb44 100644 --- a/ghc/compiler/stgSyn/StgInterp.lhs +++ b/ghc/compiler/stgSyn/StgInterp.lhs @@ -65,16 +65,14 @@ import GlaExts ( Int(..) ) import Module ( moduleNameFS ) #endif -import TyCon ( TyCon, isDataTyCon, tyConFamilySize, tyConDataCons ) -import Class ( Class, classTyCon ) +import TyCon ( TyCon ) +import Class ( Class ) import InterpSyn import StgSyn import Addr -import RdrName ( RdrName, rdrNameModule, rdrNameOcc ) -import OccName ( occNameString ) +import RdrName ( RdrName ) import FiniteMap import Panic ( panic ) -import PrelAddr -- --------------------------------------------------------------------------- -- Environments needed by the linker diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index dc7c391..7c6a27c 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -23,7 +23,6 @@ import UniqSet import VarSet import VarEnv import Unique ( Uniquable ) -import List ( elemIndex ) import Util ( zipEqual ) \end{code} diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs index bbeb51a..c107209 100644 --- a/ghc/compiler/types/Unify.lhs +++ b/ghc/compiler/types/Unify.lhs @@ -12,16 +12,14 @@ module Unify ( unifyTysX, unifyTyListsX, ) where import TypeRep ( Type(..) ) -- friend -import Type ( Kind, funTyCon, - typeKind, tyVarsOfType, splitAppTy_maybe - ) +import Type ( typeKind, tyVarsOfType, splitAppTy_maybe ) import PprType () -- Instances -- This import isn't strictly necessary, but it makes sure that -- PprType is below Unify in the hierarchy, which in turn makes -- fewer modules boot-import PprType -import Var ( TyVar, tyVarKind ) +import Var ( tyVarKind ) import VarSet import VarEnv ( TyVarSubstEnv, emptySubstEnv, lookupSubstEnv, extendSubstEnv, SubstResult(..) -- 1.7.10.4