X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=609f4230de1da82d2826720b42e28286917b8e74;hb=fe69f3c1d6062b90635963aa414c33951bf18427;hp=bea5bb293c43746658461a194c3e30daa83274bc;hpb=b78eb7be33564199dff5b03a452ea5d3b707f34d;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index bea5bb2..609f423 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -6,10 +6,13 @@ \begin{code} module RnMonad( module RnMonad, + + module RdrName, -- Re-exports + module Name, -- from these two + Module, FiniteMap, Bag, - Name, RdrNameHsDecl, RdrNameInstDecl, Version, @@ -32,35 +35,33 @@ import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig, RenamedDeprecation ) -import BasicTypes ( Version ) +import BasicTypes ( Version, defaultFixity ) import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message ) -import Name ( Name, OccName, NamedThing(..), +import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc, + RdrNameEnv, emptyRdrEnv, extendRdrEnv, + lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts + ) +import Name ( Name, OccName, NamedThing(..), getSrcLoc, isLocallyDefinedName, nameModule, nameOccName, - decode, mkLocalName + decode, mkLocalName, mkUnboundName, + NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, - mkModuleHiMaps, moduleName, mkVanillaModule, mkSearchPath + mkModuleHiMaps, moduleName, mkSearchPath ) import NameSet -import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap ) import PrelInfo ( builtinNames ) -import TysWiredIn ( boolTyCon ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique, getUnique, unboundKey ) -import UniqFM ( UniqFM ) import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, addListToFM_C, addToFM_C, eltsFM, fmToList ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) -import Maybes ( mapMaybe ) -import UniqSet -import UniqFM import UniqSupply -import Util import Outputable infixr 9 `thenRn`, `thenRn_` @@ -106,12 +107,13 @@ type RnMG r = RnM () r -- Getting global names etc -- Common part data RnDown = RnDown { - rn_mod :: ModuleName, + rn_mod :: Module, rn_loc :: SrcLoc, rn_ns :: IORef RnNameSupply, rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), rn_ifaces :: IORef Ifaces, - rn_hi_maps :: (ModuleHiMap, -- for .hi files + rn_hi_maps :: (SearchPath, -- For error messages + ModuleHiMap, -- for .hi files ModuleHiMap) -- for .hi-boot files } @@ -147,55 +149,25 @@ data RnMode = SourceMode -- Renaming source code \begin{code} -------------------------------- -type RdrNameEnv a = FiniteMap RdrName a type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes -- These only get reported on lookup, -- not on construction type LocalRdrEnv = RdrNameEnv Name -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList - --------------------------------- -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -nameEnvElts :: NameEnv a -> [a] -addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool - -emptyNameEnv = emptyUFM -nameEnvElts = eltsUFM -addToNameEnv_C = addToUFM_C -addToNameEnv = addToUFM -plusNameEnv = plusUFM -extendNameEnv = addListToUFM -lookupNameEnv = lookupUFM -delFromNameEnv = delFromUFM -elemNameEnv = elemUFM - -------------------------------- type FixityEnv = NameEnv RenamedFixitySig -- We keep the whole fixity sig so that we -- can report line-number info when there is a duplicate -- fixity declaration +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env name + = case lookupNameEnv env name of + Just (FixitySig _ fix _) -> fix + Nothing -> defaultFixity + -------------------------------- -type DeprecationEnv = NameEnv RenamedDeprecation +type DeprecationEnv = NameEnv DeprecTxt \end{code} \begin{code} @@ -203,19 +175,6 @@ type DeprecationEnv = NameEnv RenamedDeprecation type RnNameSupply = ( UniqSupply - , FiniteMap String Int - -- This is used as a name supply for dictionary functions - -- From the inst decl we derive a string, usually by glomming together - -- the class and tycon name -- but it doesn't matter exactly how; - -- this map then gives a unique int for each inst decl with that - -- string. (In Haskell 98 there can only be one, - -- but not so in more extended versions; also class CC type T - -- and class C type TT might both give the string CCT - -- - -- We could just use one Int for all the instance decls, but this - -- way the uniques change less when you add an instance decl, - -- hence less recompilation - , FiniteMap (ModuleName, OccName) Name -- Ensures that one (module,occname) pair gets one unique , FiniteMap OccName Name @@ -224,21 +183,15 @@ type RnNameSupply -------------------------------- -data ExportEnv = ExportEnv Avails Fixities [ModuleName] - -- The list of modules is the modules exported - -- with 'module M' in the export list - type Avails = [AvailInfo] -type Fixities = [(Name, Fixity)] type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers -- Includes avails only from *unqualified* imports -- (see 1.4 Report Section 5.1.1) - NameEnv AvailInfo) -- Used to figure out all other export specifiers. - -- Maps a Name to the AvailInfo that contains it - + AvailEnv) -- Used to figure out all other export specifiers. + data GenAvailInfo name = Avail name -- An ordinary identifier | AvailTC name -- The name of the type or class @@ -246,7 +199,10 @@ data GenAvailInfo name = Avail name -- An ordinary identifier -- NB: If the type or class is itself -- to be in scope, it must be in this list. -- Thus, typically: AvailTC Eq [Eq, ==, /=] + deriving( Eq ) + -- Equality used when deciding if the interface has changed +type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it type AvailInfo = GenAvailInfo Name type RdrAvailInfo = GenAvailInfo OccName \end{code} @@ -257,9 +213,12 @@ type RdrAvailInfo = GenAvailInfo OccName \begin{code} type ExportItem = (ModuleName, [RdrAvailInfo]) -type VersionInfo name = [ImportVersion name] -type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name) +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 @@ -268,39 +227,42 @@ type WhetherHasOrphans = Bool -- * a transformation rule in a module other than the one defining -- the function in the head of the rule. -data WhatsImported name = Everything - | Specifically [LocalVersion name] -- List guaranteed non-empty +type IsBootInterface = Bool - -- ("M", hif, ver, Everything) means there was a "module M" in - -- this module's export list, so we just have to go by M's version, "ver", - -- not the list of LocalVersions. +data WhatsImported name = NothingAtAll -- The module is below us in the + -- hierarchy, but we import nothing + | Everything Version -- The module version -type LocalVersion name = (name, 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. + -- 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 data ParsedIface = ParsedIface { - pi_mod :: Version, -- Module version number + pi_mod :: Module, -- Complete with package info + pi_vers :: Version, -- Module version number pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans pi_usages :: [ImportVersion OccName], -- Usages pi_exports :: [ExportItem], -- Exports - pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions pi_insts :: [RdrNameInstDecl], -- Local instance declarations - pi_rules :: [RdrNameRuleDecl], -- Rules + pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, with their version + pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version pi_deprecs :: [RdrNameDeprecation] -- Deprecations } -data InterfaceDetails - = InterfaceDetails WhetherHasOrphans - (VersionInfo Name) -- Version information for what this module imports - ExportEnv -- What modules this one depends on - [Deprecation Name] - - --- needed by Main to fish out the fixities assoc list. -getIfaceFixities :: InterfaceDetails -> Fixities -getIfaceFixities (InterfaceDetails _ _ (ExportEnv _ fs _) _) = fs - type RdrNamePragma = () -- Fudge for now ------------------- @@ -314,8 +276,14 @@ data Ifaces = Ifaces { iDecls :: DeclsMap, -- A single, global map of Names to decls - iFixes :: FixityEnv, -- A single, global map of Names to fixities - -- See comments with RnIfaces.lookupFixity + iDeferred :: NameSet, -- data (not newtype) TyCons that have been slurped, + -- but none of their constructors have. + -- If this is still the case right at the end + -- we can get away with importing them abstractly + + iFixes :: FixityEnv, + -- A single, global map of Names to fixities + -- See comments with RnIfaces.lookupFixity iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, @@ -327,22 +295,28 @@ data Ifaces = Ifaces { -- This is used to generate the "usage" information for this module. -- Subset of the previous field. - iInsts :: Bag GatedDecl, + iInsts :: IfaceInsts, -- The as-yet un-slurped instance decls; this bag is depleted when we -- slurp an instance decl so that we don't slurp the same one twice. -- Each is 'gated' by the names that must be available before -- this instance decl is needed. - iRules :: Bag GatedDecl, - -- Ditto transformation rules + iRules :: IfaceRules, + -- Similar to instance decls, only for rules iDeprecs :: DeprecationEnv } +type IfaceInsts = Bag GatedDecl +type IfaceRules = Bag GatedDecl + type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) type ImportedModuleInfo - = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails)) + = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface, + Maybe (Module, Version, Version, Version, WhereFrom, Avails)) + -- The three Versions are module version, fixity version, rules version + -- Suppose the domain element is module 'A' -- -- The first Bool is True if A contains @@ -376,13 +350,13 @@ type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) %************************************************************************ \begin{code} -initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc +initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc -> RnMG r -> IO (r, Bag ErrMsg, Bag WarnMsg) initRn mod us dirs loc do_rn = do himaps <- mkModuleHiMaps dirs - names_var <- newIORef (us, emptyFM, builtins, emptyFM) + names_var <- newIORef (us, builtins, emptyFM) errs_var <- newIORef (emptyBag,emptyBag) iface_var <- newIORef emptyIfaces let @@ -412,11 +386,12 @@ initRnMS rn_env fixity_env mode thing_inside rn_down g_down initIfaceRnMS :: Module -> RnMS r -> RnM d r initIfaceRnMS mod thing_inside = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $ - setModuleRn (moduleName mod) thing_inside + setModuleRn mod thing_inside emptyIfaces :: Ifaces emptyIfaces = Ifaces { iImpModInfo = emptyFM, iDecls = emptyNameEnv, + iDeferred = emptyNameSet, iFixes = emptyNameEnv, iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), -- Pretend that the dummy unbound name has already been @@ -428,14 +403,6 @@ emptyIfaces = Ifaces { iImpModInfo = emptyFM, iDeprecs = emptyNameEnv } --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc - -isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey - builtins :: FiniteMap (ModuleName,OccName) Name builtins = bagToFM ( @@ -452,12 +419,12 @@ The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than once you must either split it, or install a fresh unique supply. \begin{code} -renameSourceCode :: ModuleName +renameSourceCode :: Module -> RnNameSupply -> RnMS r -> r -renameSourceCode mod_name name_supply m +renameSourceCode mod name_supply m = unsafePerformIO ( -- It's not really unsafe! When renaming source code we -- only do any I/O if we need to read in a fixity declaration; @@ -469,7 +436,7 @@ renameSourceCode mod_name name_supply m let rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, rn_errs = errs_var, rn_hi_maps = himaps, - rn_mod = mod_name, + rn_mod = mod, rn_ifaces = panic "rnameSourceCode: rn_ifaces" -- Not required } s_down = SDown { rn_mode = InterfaceMode, @@ -645,26 +612,13 @@ setNameSupplyRn :: RnNameSupply -> RnM d () setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down = writeIORef names_var names' --- See comments with RnNameSupply above. -newInstUniq :: String -> RnM d Int -newInstUniq key (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache, ipcache) -> - let - uniq = case lookupFM mapInst key of - Just x -> x+1 - Nothing -> 0 - mapInst' = addToFM mapInst key uniq - in - writeIORef names_var (us, mapInst', cache, ipcache) >> - return uniq - getUniqRn :: RnM d Unique getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache, ipcache) -> + = readIORef names_var >>= \ (us, cache, ipcache) -> let (us1,us') = splitUniqSupply us in - writeIORef names_var (us', mapInst, cache, ipcache) >> + writeIORef names_var (us', cache, ipcache) >> return (uniqFromSupply us1) \end{code} @@ -673,11 +627,11 @@ getUniqRn (RnDown {rn_ns = names_var}) l_down %===================== \begin{code} -getModuleRn :: RnM d ModuleName -getModuleRn (RnDown {rn_mod = mod_name}) l_down - = return mod_name +getModuleRn :: RnM d Module +getModuleRn (RnDown {rn_mod = mod}) l_down + = return mod -setModuleRn :: ModuleName -> RnM d a -> RnM d a +setModuleRn :: Module -> RnM d a -> RnM d a setModuleRn new_mod enclosed_thing rn_down l_down = enclosed_thing (rn_down {rn_mod = new_mod}) l_down \end{code} @@ -702,6 +656,10 @@ getLocalNameEnv :: RnMS LocalRdrEnv getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) = return local_env +getGlobalNameEnv :: RnMS GlobalRdrEnv +getGlobalNameEnv rn_down (SDown {rn_genv = global_env}) + = return global_env + setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a setLocalNameEnv local_env' m rn_down l_down = m rn_down (l_down {rn_lenv = local_env'}) @@ -714,7 +672,7 @@ extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a extendFixityEnv fixes enclosed_scope rn_down l_down@(SDown {rn_fixenv = fixity_env}) = let - new_fixity_env = extendNameEnv fixity_env fixes + new_fixity_env = extendNameEnvList fixity_env fixes in enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env}) \end{code} @@ -749,17 +707,8 @@ setIfacesRn :: Ifaces -> RnM d () setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ = writeIORef iface_var ifaces -getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap) +getHiMaps :: RnM d (SearchPath, ModuleHiMap, ModuleHiMap) getHiMaps (RnDown {rn_hi_maps = himaps}) _ = return himaps \end{code} - -\begin{code} -lookupModuleRn :: ModuleName -> RnM d Module -lookupModuleRn x = - getHiMaps `thenRn` \ (himap, _) -> - case lookupFM himap x of - Nothing -> returnRn (mkVanillaModule x) - Just (_,x) -> returnRn x - \end{code}