X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=6a6acbb343936011dc008ece537d583aa3132a4d;hb=e7b69c553c58133ddbdc756bec03a43d35b0be5e;hp=0d562d3114e739be9360eb062577e48ed088026a;hpb=cd241c73f2b03a48d905e0db50c796eb0de45dec;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 0d562d3..6a6acbb 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -31,43 +31,44 @@ import PrelIOBase ( fixIO ) -- Should be in GlaExts import IOBase ( fixIO ) #endif import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) +import IO ( hPutStr, stderr ) import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig ) import HscTypes ( AvailEnv, lookupType, - OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, - WhetherHasOrphans, ImportVersion, - PersistentRenamerState(..), IsBootInterface, Avails, + NameSupply(..), + ImportedModuleInfo, WhetherHasOrphans, ImportVersion, + PersistentRenamerState(..), Avails, DeclsMap, IfaceInsts, IfaceRules, HomeSymbolTable, TyThing, - PersistentCompilerState(..), GlobalRdrEnv, + PersistentCompilerState(..), GlobalRdrEnv, LocalRdrEnv, HomeIfaceTable, PackageIfaceTable, RdrAvailInfo ) import BasicTypes ( Version, defaultFixity ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, ErrMsg, WarnMsg, Message + Message, Messages, errorsFound, warningsFound, + printErrorsAndWarnings ) import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc, RdrNameEnv, emptyRdrEnv, extendRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts ) -import Name ( Name, OccName, NamedThing(..), getSrcLoc, +import Name ( Name, OccName, NamedThing(..), nameOccName, decode, mkLocalName, mkKnownKeyGlobal ) -import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) +import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, extendNameEnvList ) import Module ( Module, ModuleName, ModuleSet, emptyModuleSet ) import NameSet import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc ) import Unique ( Unique ) -import FiniteMap ( FiniteMap, emptyFM ) +import FiniteMap ( FiniteMap ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable import PrelNames ( mkUnboundName ) -import ErrUtils ( printErrorsAndWarnings ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -92,12 +93,13 @@ ioToRnM_no_fail io rn_down g_down (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!") traceRn :: SDoc -> RnM d () -traceRn msg - = doptRn Opt_D_dump_rn_trace `thenRn` \b -> - if b then putDocRn msg else returnRn () +traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg) + +traceHiDiffsRn :: SDoc -> RnM d () +traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg) putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printErrs msg) `thenRn_` +putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_` returnRn () \end{code} @@ -134,10 +136,8 @@ data RnDown -- The Name passed to rn_done is guaranteed to be a Global, -- so it has a Module, so it can be looked up - rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), - - -- The second and third components are a flattened-out OrigNameEnv - rn_ns :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv), + rn_errs :: IORef Messages, + rn_ns :: IORef NameSupply, rn_ifaces :: IORef Ifaces } @@ -162,8 +162,12 @@ data SDown = SDown { -- with RnIfaces.lookupLocalFixity } -data RnMode = SourceMode -- Renaming source code - | InterfaceMode -- Renaming interface declarations. +data RnMode = SourceMode -- Renaming source code + | InterfaceMode -- Renaming interface declarations. + | CmdLineMode -- Renaming a command-line expression + +isInterfaceMode InterfaceMode = True +isInterfaceMode _ = False \end{code} %=================================================== @@ -172,12 +176,14 @@ data RnMode = SourceMode -- Renaming source code \begin{code} -------------------------------- -type LocalRdrEnv = RdrNameEnv Name type LocalFixityEnv = NameEnv RenamedFixitySig -- We keep the whole fixity sig so that we -- can report line-number info when there is a duplicate -- fixity declaration +emptyLocalFixityEnv :: LocalFixityEnv +emptyLocalFixityEnv = emptyNameEnv + lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity lookupLocalFixity env name = case lookupNameEnv env name of @@ -244,6 +250,11 @@ data Ifaces = Ifaces { -- package symbol table, and the renamer incrementally adds -- to it. + iImpModInfo :: ImportedModuleInfo, + -- Modules that we know something about, because they are mentioned + -- in interface files, BUT which we have not loaded yet. + -- No module is both in here and in the PIT + iDecls :: DeclsMap, -- A single, global map of Names to unslurped decls @@ -258,15 +269,15 @@ data Ifaces = Ifaces { -- EPHEMERAL FIELDS -- These fields persist during the compilation of a single module only - iImpModInfo :: ImportedModuleInfo, - -- Modules this one depends on: that is, the union - -- of the modules its *direct* imports depend on. - -- NB: The direct imports have .hi files that enumerate *all* the - -- dependencies (direct or not) of the imported module. - iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, -- whether locally defined or not) that have been slurped in so far. + -- + -- It's used for two things: + -- a) To record what we've already slurped, so + -- we can no-op if we try to slurp it again + -- b) As the 'gates' for importing rules. We import a rule + -- if all its LHS free vars have been slurped iVSlurp :: (ModuleSet, NameSet) -- The Names are all the (a) non-wired-in @@ -276,16 +287,13 @@ data Ifaces = Ifaces { -- 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. + -- -- The module set is the non-home-package modules from which we have -- slurped at least one name. -- 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 (WhetherHasOrphans, IsBootInterface) - -- Contains info ONLY about modules that have not yet - --- been loaded into the iPIT \end{code} @@ -296,13 +304,18 @@ type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterfa %************************************************************************ \begin{code} +runRn dflags hit hst pcs mod do_rn + = do { (pcs, msgs, r) <- initRn dflags hit hst pcs mod do_rn ; + printErrorsAndWarnings alwaysQualify msgs ; + return (pcs, errorsFound msgs, r) + } + initRn :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RnMG t - -> IO (PersistentCompilerState, Bool, t) - -- True <=> found errors + -> IO (PersistentCompilerState, Messages, t) initRn dflags hit hst pcs mod do_rn = do @@ -313,17 +326,14 @@ initRn dflags hit hst pcs mod do_rn iInsts = prsInsts prs, iRules = prsRules prs, - iImpModInfo = emptyFM, + iImpModInfo = prsImpMods prs, iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), -- Pretend that the dummy unbound name has already been -- slurped. This is what's returned for an out-of-scope name, -- and we don't want thereby to try to suck it in! iVSlurp = (emptyModuleSet, emptyNameSet) } - let uniqs = prsNS prs - - names_var <- newIORef (uniqs, origNames (prsOrig prs), - origIParam (prsOrig prs)) + names_var <- newIORef (prsOrig prs) errs_var <- newIORef (emptyBag,emptyBag) iface_var <- newIORef ifaces let rn_down = RnDown { rn_mod = mod, @@ -342,39 +352,38 @@ initRn dflags hit hst pcs mod do_rn res <- do_rn rn_down () -- Grab state and record it - (warns, errs) <- readIORef errs_var - new_ifaces <- readIORef iface_var - (new_NS, new_origN, new_origIP) <- readIORef names_var - let new_orig = Orig { origNames = new_origN, origIParam = new_origIP } - let new_prs = prs { prsOrig = new_orig, - prsDecls = iDecls new_ifaces, - prsInsts = iInsts new_ifaces, - prsRules = iRules new_ifaces, - prsNS = new_NS } + (warns, errs) <- readIORef errs_var + new_ifaces <- readIORef iface_var + new_orig <- readIORef names_var + let new_prs = prs { prsOrig = new_orig, + prsImpMods = iImpModInfo new_ifaces, + prsDecls = iDecls new_ifaces, + prsInsts = iInsts new_ifaces, + prsRules = iRules new_ifaces } let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, pcs_PRS = new_prs } - -- Check for warnings - printErrorsAndWarnings (warns, errs) ; + return (new_pcs, (warns, errs), res) - return (new_pcs, not (isEmptyBag errs), res) +initRnMS :: GlobalRdrEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode + -> RnMS a -> RnM d a -initRnMS rn_env fixity_env mode thing_inside rn_down g_down +initRnMS rn_env local_env fixity_env mode thing_inside rn_down g_down -- The fixity_env appears in both the rn_fixenv field -- and in the HIT. See comments with RnHiFiles.lookupFixityRn = let - s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, + s_down = SDown { rn_genv = rn_env, rn_lenv = local_env, rn_fixenv = fixity_env, rn_mode = mode } in thing_inside rn_down s_down initIfaceRnMS :: Module -> RnMS r -> RnM d r initIfaceRnMS mod thing_inside - = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $ + = initRnMS emptyRdrEnv emptyRdrEnv emptyLocalFixityEnv InterfaceMode $ setModuleRn mod thing_inside \end{code} -@renameSourceCode@ is used to rename stuff ``out-of-line''; +@renameDerivedCode@ is used to rename stuff ``out-of-line''; that is, not as part of the main renamer. Sole examples: derived definitions, which are only generated in the type checker. @@ -383,52 +392,53 @@ The @NameSupply@ 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 :: DynFlags - -> Module - -> PersistentRenamerState - -> RnMS r - -> r - -renameSourceCode dflags mod prs m - = unsafePerformIO ( +renameDerivedCode :: DynFlags + -> Module + -> PersistentRenamerState + -> RnMS r + -> r + +renameDerivedCode dflags mod prs thing_inside + = 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; -- and that doesn't happen in pragmas etc - mkSplitUniqSupply 'r' >>= \ new_us -> - newIORef (new_us, origNames (prsOrig prs), - origIParam (prsOrig prs)) >>= \ names_var -> - newIORef (emptyBag,emptyBag) >>= \ errs_var -> - let - rn_down = RnDown { rn_dflags = dflags, - rn_loc = generatedSrcLoc, rn_ns = names_var, - rn_errs = errs_var, - rn_mod = mod, - rn_done = bogus "rn_done", rn_hit = bogus "rn_hit", - rn_ifaces = bogus "rn_ifaces" - } - s_down = SDown { rn_mode = InterfaceMode, + do { us <- mkSplitUniqSupply 'r' + ; names_var <- newIORef ((prsOrig prs) { nsUniqs = us }) + ; errs_var <- newIORef (emptyBag,emptyBag) + + ; let rn_down = RnDown { rn_dflags = dflags, + rn_loc = generatedSrcLoc, rn_ns = names_var, + rn_errs = errs_var, + rn_mod = mod, + rn_done = bogus "rn_done", + rn_hit = bogus "rn_hit", + rn_ifaces = bogus "rn_ifaces" + } + ; let s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc - rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, - rn_fixenv = emptyNameEnv } - in - m rn_down s_down >>= \ result -> - - readIORef errs_var >>= \ (warns,errs) -> + rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, + rn_fixenv = emptyLocalFixityEnv } - (if not (isEmptyBag errs) then - pprTrace "Urk! renameSourceCode found errors" (display errs) -#ifdef DEBUG - else if not (isEmptyBag warns) then - pprTrace "Note: renameSourceCode found warnings" (display warns) -#endif - else - id) $ + ; result <- thing_inside rn_down s_down + ; messages <- readIORef errs_var + + ; if bad messages then + do { hPutStr stderr "Urk! renameDerivedCode found errors or warnings" + ; printErrorsAndWarnings alwaysQualify messages + } + else + return() - return result - ) + ; return result + } where - display errs = pprBagOfErrors errs +#ifdef DEBUG + bad messages = errorsFound messages || warningsFound messages +#else + bad messages = errorsFound messages +#endif bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields @@ -445,7 +455,8 @@ mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] flatMapRn :: (a -> RnM d [b]) -> [a] -> RnM d [b] -sequenceRn :: [RnM d a] -> RnM d [a] +sequenceRn :: [RnM d a] -> RnM d [a] +sequenceRn_ :: [RnM d a] -> RnM d () foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) fixRn :: (a -> RnM d a) -> RnM d a @@ -461,9 +472,12 @@ andRn combiner m1 m2 gdown ldown sequenceRn [] = returnRn [] sequenceRn (m:ms) = m `thenRn` \ r -> - sequenceRn ms `thenRn` \ rs -> + sequenceRn ms `thenRn` \ rs -> returnRn (r:rs) +sequenceRn_ [] = returnRn () +sequenceRn_ (m:ms) = m `thenRn_` sequenceRn_ ms + mapRn f [] = returnRn [] mapRn f (x:xs) = f x `thenRn` \ r -> @@ -557,6 +571,11 @@ doptRn :: DynFlag -> RnM d Bool doptRn dflag (RnDown { rn_dflags = dflags}) l_down = return (dopt dflag dflags) +ifOptRn :: DynFlag -> RnM d a -> RnM d () +ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down + | dopt dflag dflags = thing_inside down l_down >> return () + | otherwise = return () + getDOptsRn :: RnM d DynFlags getDOptsRn (RnDown { rn_dflags = dflags}) l_down = return dflags @@ -594,21 +613,21 @@ getTypeEnvRn down l_down = return (rn_done down) %===================== \begin{code} -getNameSupplyRn :: RnM d (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) +getNameSupplyRn :: RnM d NameSupply getNameSupplyRn rn_down l_down = readIORef (rn_ns rn_down) -setNameSupplyRn :: (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) -> RnM d () +setNameSupplyRn :: NameSupply -> RnM d () setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down = writeIORef names_var names' getUniqRn :: RnM d Unique getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, cache, ipcache) -> + = readIORef names_var >>= \ ns -> let - (us1,us') = splitUniqSupply us + (us1,us') = splitUniqSupply (nsUniqs ns) in - writeIORef names_var (us', cache, ipcache) >> + writeIORef names_var (ns {nsUniqs = us'}) >> return (uniqFromSupply us1) \end{code}