X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=27feac14f33e998caeec8eb3c83ab2b55a05b546;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=09cecfab780cbd113942289996c8000edf070200;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 09cecfa..27feac1 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnMonad]{The monad used by the renamer} @@ -22,30 +22,38 @@ module RnMonad( import SST import GlaExts ( RealWorld, stToIO ) +import List ( intersperse ) import HsSyn import RdrHsSyn -import BasicTypes ( Version, NewOrData, pprModule ) +import BasicTypes ( Version, pprModule, IfaceFlavour(..) ) import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg ) -import Name ( Module, Name, OccName, PrintUnqualified, NameSet, emptyNameSet, +import Name ( Module, Name, OccName, PrintUnqualified, isLocallyDefinedName, modAndOcc, NamedThing(..) ) -import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas ) +import NameSet +import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, opt_WarnHiShadows ) import PrelInfo ( builtinNames ) import TysWiredIn ( boolTyCon ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique ) import UniqFM ( UniqFM ) -import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM ) +import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM_C, addToFM_C ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) +import Maybes ( seqMaybe, mapMaybe ) import UniqSet import UniqSupply import Util import Outputable +import DirUtils ( getDirectoryContents ) +import IO ( hPutStrLn, stderr, isDoesNotExistError ) +import Monad ( foldM ) +import Maybe ( fromMaybe ) +import Constants ( interfaceFileFormatVersion ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -93,7 +101,7 @@ type SSTRWRef a = SSTRef RealWorld a -- ToDo: there ought to be a standard defn -- Common part data RnDown s = RnDown SrcLoc - (SSTRef s RnNameSupply) + (SSTRef s (GenRnNameSupply s)) (SSTRef s (Bag WarnMsg, Bag ErrMsg)) (SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp @@ -105,7 +113,8 @@ data Necessity = Compulsory | Optional -- We *must* find definitions for -- For getting global names data GDown = GDown - SearchPath + ModuleHiMap -- for .hi files + ModuleHiMap -- for .hi-boot files (SSTRWRef Ifaces) -- For renaming source code @@ -130,6 +139,11 @@ data RnSMode = SourceMode -- Renaming source code type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search -- for interface files. + +type ModuleHiMap = FiniteMap String String + -- mapping from module name to the file path of its corresponding + -- interface file. + type FreeVars = NameSet \end{code} @@ -138,10 +152,16 @@ type FreeVars = NameSet =================================================== \begin{code} -type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name) +type RnNameSupply = GenRnNameSupply RealWorld + +type GenRnNameSupply s + = ( UniqSupply + , FiniteMap FAST_STRING (SSTRef s Int) + , FiniteMap (Module,OccName) Name + ) -- Ensures that one (m,n) pair gets one unique - -- The Int is used to give a number to each instance declaration; - -- it's really a separate name supply. + -- The finite map on FAST_STRINGS is used to give a per-class unique to each + -- instance declaration; it's really a separate name supply. data RnEnv = RnEnv GlobalNameEnv FixityEnv emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv @@ -277,22 +297,22 @@ initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc -> RnMG r -> IO (r, Bag ErrMsg, Bag WarnMsg) -initRn mod us dirs loc do_rn - = sstToIO $ - newMutVarSST (us, 1, builtins) `thenSST` \ names_var -> - newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> - newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var -> - newMutVarSST initOccs `thenSST` \ occs_var -> - let - rn_down = RnDown loc names_var errs_var occs_var - g_down = GDown dirs iface_var - in - -- do the buisness - do_rn rn_down g_down `thenSST` \ res -> +initRn mod us dirs loc do_rn = do + names_var <- sstToIO (newMutVarSST (us, emptyFM, builtins)) + errs_var <- sstToIO (newMutVarSST (emptyBag,emptyBag)) + iface_var <- sstToIO (newMutVarSST (emptyIfaces mod)) + occs_var <- sstToIO (newMutVarSST initOccs) + (himap, hibmap) <- mkModuleHiMaps dirs + let + rn_down = RnDown loc names_var errs_var occs_var + g_down = GDown himap hibmap iface_var + + -- do the business + res <- sstToIO (do_rn rn_down g_down) -- grab errors and return - readMutVarSST errs_var `thenSST` \ (warns,errs) -> - returnSST (res, errs, warns) + (warns, errs) <- sstToIO (readMutVarSST errs_var) + return (res, errs, warns) initRnMS :: RnEnv -> Module -> RnSMode -> RnMS RealWorld r -> RnMG r @@ -318,6 +338,80 @@ initOccs = ([(getName boolTyCon, noSrcLoc)], []) -- to do as much as possible explicitly. \end{code} +\begin{code} +mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap) +mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs + where + env = emptyFM + +getAllFilesMatching :: SearchPath + -> (ModuleHiMap, ModuleHiMap) + -> (FilePath, String) + -> IO (ModuleHiMap, ModuleHiMap) +getAllFilesMatching dirs hims (dir_path, suffix) = ( do + -- fpaths entries do not have dir_path prepended + fpaths <- getDirectoryContents dir_path + return (foldl addModules hims fpaths) + ) -- soft failure + `catch` + (\ err -> do + hPutStrLn stderr + ("Import path element `" ++ dir_path ++ + if (isDoesNotExistError err) then + "' does not exist, ignoring." + else + "' couldn't read, ignoring.") + + return hims + ) + where + xiffus = reverse dotted_suffix + + dotted_suffix = + case suffix of + [] -> [] + ('.':xs) -> suffix + ls -> '.':ls + + hi_boot_version_xiffus = + reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus + hi_boot_xiffus = "toob-ih." -- .hi-boot reversed. + + addModules his@(hi_env, hib_env) nm = fromMaybe his $ + map (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm v, hib_env)) + (go xiffus rev_nm) `seqMaybe` + + map (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm v)) + (go hi_boot_version_xiffus rev_nm) `seqMaybe` + + map (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm v)) + (go hi_boot_xiffus rev_nm) + where + rev_nm = reverse nm + + go [] xs = Just (reverse xs, dir_path ++'/':nm) + go _ [] = Nothing + go (x:xs) (y:ys) + | x == y = go xs ys + | otherwise = Nothing + + addNewOne + | opt_WarnHiShadows = conflict + | otherwise = stickWithOld + + stickWithOld old new = old + overrideNew old new = new + + conflict old_path new_path + | old_path /= new_path = + pprTrace "Warning: " (text "Identically named interface files present on import path, " $$ + text (show old_path) <+> text "shadows" $$ + text (show new_path) $$ + text "on the import path: " <+> + text (concat (intersperse ":" (map fst dirs)))) + old_path + | otherwise = old_path -- don't warn about innocous shadowings. + \end{code} @@ -331,7 +425,7 @@ once you must either split it, or install a fresh unique supply. \begin{code} renameSourceCode :: Module - -> RnNameSupply + -> RnNameSupply -> RnMS RealWorld r -> r @@ -354,8 +448,10 @@ renameSourceCode mod_name name_supply m (if not (isEmptyBag errs) then pprTrace "Urk! renameSourceCode found errors" (display errs) +#ifdef DEBUG else if not (isEmptyBag warns) then pprTrace "Urk! renameSourceCode found warnings" (display warns) +#endif else id) $ @@ -480,21 +576,34 @@ getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down ================ Name supply ===================== \begin{code} -getNameSupplyRn :: RnM s d RnNameSupply +getNameSupplyRn :: RnM s d (GenRnNameSupply s) getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST names_var -setNameSupplyRn :: RnNameSupply -> RnM s d () +setNameSupplyRn :: GenRnNameSupply s -> RnM s d () setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down = writeMutVarSST names_var names' --- The "instance-decl unique supply", inst, is just an integer that's used to --- give a unique number for each instance declaration. -newInstUniq :: RnM s d Int -newInstUniq (RnDown loc names_var errs_var occs_var) l_down - = readMutVarSST names_var `thenSST` \ (us, inst, cache) -> - writeMutVarSST names_var (us, inst+1, cache) `thenSST_` - returnSST inst +-- The "instance-decl unique supply", inst, is really a map from class names +-- to unique supplies. Having per-class unique numbers for instance decls helps +-- the recompilation checker. +newInstUniq :: FAST_STRING -> RnM s d Int +newInstUniq cname (RnDown loc names_var errs_var occs_var) l_down + = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) -> + case lookupFM mapInst cname of + Just class_us -> + readMutVarSST class_us `thenSST` \ v -> + writeMutVarSST class_us (v+1) `thenSST_` + returnSST v + Nothing -> -- first time caller gets to add a unique supply + -- to the finite map for that class. + newMutVarSST 1 `thenSST` \ class_us -> + let + mapInst' = addToFM mapInst cname class_us + in + writeMutVarSST names_var (us, mapInst', cache) `thenSST_` + returnSST 0 + \end{code} ================ Occurrences ===================== @@ -619,9 +728,11 @@ lookupGlobalNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_e -- Look in both local and global env lookupNameRn :: RdrName -> RnMS s (Maybe Name) lookupNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) - = case lookupFM global_env rdr_name of - Just (name, _) -> returnSST (Just name) - Nothing -> returnSST (lookupFM local_env rdr_name) + = case lookupFM local_env rdr_name of + Just name -> returnSST (Just name) + Nothing -> case lookupFM global_env rdr_name of + Just (name, _) -> returnSST (Just name) + Nothing -> returnSST Nothing getNameEnvs :: RnMS s (GlobalNameEnv, NameEnv) getNameEnvs rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode) @@ -667,16 +778,19 @@ setModeRn new_mode thing_inside rn_down (SDown rn_env local_env mod_name mode) \begin{code} getIfacesRn :: RnMG Ifaces -getIfacesRn rn_down (GDown dirs iface_var) +getIfacesRn rn_down (GDown himap hibmap iface_var) = readMutVarSST iface_var setIfacesRn :: Ifaces -> RnMG () -setIfacesRn ifaces rn_down (GDown dirs iface_var) +setIfacesRn ifaces rn_down (GDown himap hibmap iface_var) = writeMutVarSST iface_var ifaces -getSearchPathRn :: RnMG SearchPath -getSearchPathRn rn_down (GDown dirs iface_var) - = returnSST dirs +getModuleHiMap :: IfaceFlavour -> RnMG ModuleHiMap +getModuleHiMap as_source rn_down (GDown himap hibmap iface_var) + = case as_source of + HiBootFile -> returnSST hibmap + _ -> returnSST himap + \end{code} %************************************************************************