X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=1b3bcfc8ef078590babc7102b04b13e490a3e63d;hb=d2cca44eae15bbbd3b86889448e796bc785dfa52;hp=ddff54f80d450ea6ff59a9fe8b1100f72d8b6269;hpb=9bedea20f62a1da832c69833c39dd1d15e6ee9a3;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index ddff54f..1b3bcfc 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -35,6 +35,16 @@ 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, + RdrAvailInfo, ModIface ) import BasicTypes ( Version, defaultFixity ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message @@ -49,24 +59,17 @@ import Name ( Name, OccName, NamedThing(..), getSrcLoc, NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) -import Module ( Module, ModuleName, WhereFrom, moduleName ) +import Module ( Module, ModuleName, lookupModuleEnvByName ) 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 ) +import Maybes ( maybeToBool, seqMaybe, orElse ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -118,7 +121,13 @@ data RnDown rn_finder :: Finder, rn_dflags :: DynFlags, - rn_hst :: HomeSymbolTable, + + rn_hit :: HomeIfaceTable, + 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), @@ -184,6 +193,7 @@ type ExportAvails = (FiniteMap ModuleName Avails, %=================================================== \begin{code} +type ExportItem = (ModuleName, [RdrAvailInfo]) data ParsedIface = ParsedIface { @@ -191,10 +201,10 @@ data ParsedIface pi_vers :: Version, -- Module version number pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans pi_usages :: [ImportVersion OccName], -- Usages - pi_exports :: [ExportItem], -- Exports + pi_exports :: (Version, [ExportItem]), -- Exports pi_insts :: [RdrNameInstDecl], -- Local instance declarations pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions - pi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, with their version + pi_fixity :: [RdrNameFixitySig], -- Local fixity declarations, pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version pi_deprecs :: [RdrNameDeprecation] -- Deprecations } @@ -209,18 +219,18 @@ data ParsedIface \begin{code} data Ifaces = Ifaces { -- PERSISTENT FIELDS - iPST :: PackageSymbolTable, - -- The ModuleDetails for modules in other packages + iPIT :: PackageIfaceTable, + -- The ModuleIFaces for modules in other packages -- whose interfaces we have opened - -- The contents of those interface files may be mostly - -- in the iDecls, iInsts, iRules (below), but what *will* - -- be in the PackageSymbolTable is: + -- The declarations in these interface files are held in + -- iDecls, iInsts, iRules (below), not in the mi_decls fields + -- of the iPIT. What _is_ in the iPIT is: -- * The Module -- * Version info -- * Its exports -- * Fixities -- * Deprecations - -- This field is initialised from the compiler's persistent + -- The iPIT field is initialised from the compiler's persistent -- package symbol table, and the renamer incrementally adds -- to it. @@ -248,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 @@ -268,15 +281,21 @@ type IsLoaded = Bool %************************************************************************ \begin{code} -initRn :: DynFlags -> Finder -> HomeSymbolTable +initRn :: DynFlags + -> Finder + -> HomeIfaceTable + -> HomeSymbolTable -> PersistentCompilerState - -> Module -> SrcLoc + -> Module + -> SrcLoc -> RnMG t - -> IO (t, PersistentCompilerState, (Bag WarnMsg, Bag ErrMsg)) + -> IO (t, (Bag WarnMsg, Bag ErrMsg), PersistentCompilerState) -initRn dflags finder hst 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)) @@ -287,7 +306,8 @@ initRn dflags finder hst pcs mod loc do_rn rn_finder = finder, rn_dflags = dflags, - rn_hst = hst, + rn_hit = hit, + rn_done = is_done hst pst, rn_ns = names_var, rn_errs = errs_var, @@ -306,15 +326,23 @@ initRn dflags finder hst 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)) + return (res, (warns, errs), new_pcs) + +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 :: HomeIfaceTable -> PackageIfaceTable -> 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, @@ -373,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_done = bogus "rn_done", rn_hit = bogus "rn_hit", + rn_ifaces = bogus "rn_ifaces", rn_finder = bogus "rn_finder" } s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc @@ -398,6 +427,8 @@ renameSourceCode dflags mod prs m where display errs = pprBagOfErrors errs +bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields + {-# INLINE thenRn #-} {-# INLINE thenRn_ #-} {-# INLINE returnRn #-} @@ -530,7 +561,7 @@ getDOptsRn (RnDown { rn_dflags = dflags}) l_down %================ -\subsubsection{ Source location} +\subsubsection{Source location} %===================== \begin{code} @@ -551,8 +582,11 @@ getSrcLocRn down l_down getFinderRn :: RnM d Finder getFinderRn down l_down = return (rn_finder down) -getHomeSymbolTableRn :: RnM d HomeSymbolTable -getHomeSymbolTableRn down l_down = return (rn_hst 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} %================