X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=2fae263656ebc3f89ae59aab28b64a6b57be47e0;hb=9fc29e6eedbb0cee53960a0664d99c0b2c33f3d7;hp=74101b781c154b750b5342a5f20720a3474018c6;hpb=156d91339295539a2b3461efc1ac8c83f29d83f0;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 74101b7..2fae263 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -31,33 +31,34 @@ 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, + OrigNameEnv(..), WhetherHasOrphans, ImportVersion, PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, IfaceInsts, IfaceRules, - HomeSymbolTable, PackageTypeEnv, + HomeSymbolTable, TyThing, PersistentCompilerState(..), GlobalRdrEnv, 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, - isLocallyDefinedName, nameOccName, - decode, mkLocalName, mkKnownKeyGlobal, - NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, - extendNameEnvList +import Name ( Name, OccName, NamedThing(..), + nameOccName, + decode, mkLocalName, mkKnownKeyGlobal ) +import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList ) import Module ( Module, ModuleName, ModuleSet, emptyModuleSet ) import NameSet import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) @@ -68,8 +69,6 @@ import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable import PrelNames ( mkUnboundName ) -import Maybes ( maybeToBool, seqMaybe ) -import ErrUtils ( printErrorsAndWarnings ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -98,8 +97,13 @@ traceRn msg = doptRn Opt_D_dump_rn_trace `thenRn` \b -> if b then putDocRn msg else returnRn () +traceHiDiffsRn :: SDoc -> RnM d () +traceHiDiffsRn msg + = doptRn Opt_D_dump_hi_diffs `thenRn` \b -> + if b then putDocRn msg else returnRn () + putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printErrs msg) `thenRn_` +putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_` returnRn () \end{code} @@ -128,16 +132,16 @@ data RnDown rn_dflags :: DynFlags, 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), - - -- The second and third components are a flattened-out OrigNameEnv - rn_ns :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv), + rn_done :: Name -> Maybe TyThing, -- Tells what things (both in the + -- home package and other packages) + -- were already available (i.e. in + -- the relevant SymbolTable) before + -- compiling this module + -- 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 Messages, + rn_ns :: IORef OrigNameEnv, rn_ifaces :: IORef Ifaces } @@ -145,7 +149,7 @@ data RnDown data SDown = SDown { rn_mode :: RnMode, - rn_genv :: GlobalRdrEnv, -- Global envt + rn_genv :: GlobalRdrEnv, -- Top level environment rn_lenv :: LocalRdrEnv, -- Local name envt -- Does *not* include global name envt; may shadow it @@ -155,9 +159,10 @@ data SDown = SDown { -- We still need the unsullied global name env so that -- we can look up record field names - rn_fixenv :: LocalFixityEnv -- Local fixities + rn_fixenv :: LocalFixityEnv -- Local fixities (for non-top-level + -- declarations) -- The global fixities are held in the - -- rn_ifaces field. Why? See the comments + -- HIT or PIT. Why? See the comments -- with RnIfaces.lookupLocalFixity } @@ -177,6 +182,9 @@ type LocalFixityEnv = NameEnv RenamedFixitySig -- 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 @@ -258,10 +266,9 @@ 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. + -- 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 iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, @@ -295,13 +302,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 @@ -319,10 +331,7 @@ initRn dflags hit hst pcs mod do_rn -- 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, @@ -330,7 +339,7 @@ initRn dflags hit hst pcs mod do_rn rn_dflags = dflags, rn_hit = hit, - rn_done = is_done hst pte, + rn_done = lookupType hst pte, rn_ns = names_var, rn_errs = errs_var, @@ -341,28 +350,24 @@ 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 } + (warns, errs) <- readIORef errs_var + new_ifaces <- readIORef iface_var + new_orig <- readIORef names_var let new_prs = prs { prsOrig = new_orig, prsDecls = iDecls new_ifaces, prsInsts = iInsts new_ifaces, - prsRules = iRules new_ifaces, - prsNS = new_NS } + 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) - -is_done :: HomeSymbolTable -> PackageTypeEnv -> Name -> Bool --- Returns True iff the name is in either symbol table -is_done hst pte n = maybeToBool (lookupType hst pte n) +initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode + -> RnMS a -> RnM d a initRnMS rn_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, rn_fixenv = fixity_env, rn_mode = mode } @@ -371,12 +376,11 @@ 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 $ + = initRnMS 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. @@ -385,52 +389,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) { origNS = 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 @@ -447,7 +452,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 @@ -463,9 +469,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 -> @@ -587,8 +596,8 @@ getSrcLocRn down l_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) +getTypeEnvRn :: RnM d (Name -> Maybe TyThing) +getTypeEnvRn down l_down = return (rn_done down) \end{code} %================ @@ -596,21 +605,21 @@ checkAlreadyAvailable name down l_down = return (rn_done down name) %===================== \begin{code} -getNameSupplyRn :: RnM d (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) +getNameSupplyRn :: RnM d OrigNameEnv getNameSupplyRn rn_down l_down = readIORef (rn_ns rn_down) -setNameSupplyRn :: (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv) -> RnM d () +setNameSupplyRn :: OrigNameEnv -> 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 (origNS ns) in - writeIORef names_var (us', cache, ipcache) >> + writeIORef names_var (ns {origNS = us'}) >> return (uniqFromSupply us1) \end{code}