X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FModule.lhs;h=d67b8a5c951d07ac85290674e8d398987fdca98c;hb=8344b1e4a6e20d289cee53a4b25b18c6c28449bf;hp=92877df6e8c1543f944c5349da2674a2013ae2d2;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 92877df..d67b8a5 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -1,128 +1,103 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The University of Glasgow, 2004 % -\section[Module]{The @Module@ module.} - -Representing modules and their flavours. - - -Notes on DLLs -~~~~~~~~~~~~~ -When compiling module A, which imports module B, we need to -know whether B will be in the same DLL as A. - If it's in the same DLL, we refer to B_f_closure - If it isn't, we refer to _imp__B_f_closure -When compiling A, we record in B's Module value whether it's -in a different DLL, by setting the DLL flag. - - +Module +~~~~~~~~~~ +Simply the name of a module, represented as a Z-encoded FastString. +These are Uniquable, hence we can build FiniteMaps with ModuleNames as +the keys. \begin{code} module Module ( - Module -- abstract, instance of Eq, Ord, Outputable - , ModuleName - - , moduleNameString -- :: ModuleName -> EncodedString - , moduleNameUserString -- :: ModuleName -> UserString - - , moduleString -- :: Module -> EncodedString - , moduleUserString -- :: Module -> UserString - , moduleName -- :: Module -> ModuleName - - , mkVanillaModule -- :: ModuleName -> Module - , mkThisModule -- :: ModuleName -> Module - , mkPrelModule -- :: UserString -> Module - , mkModule -- :: ModuleName -> PackageName -> Module - - , isLocalModule -- :: Module -> Bool + Module, -- Abstract, instance of Eq, Ord, Outputable + , pprModule -- :: ModuleName -> SDoc - , mkSrcModule + , ModLocation(..), + , addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, - , mkSrcModuleFS -- :: UserFS -> ModuleName - , mkSysModuleFS -- :: EncodedFS -> ModuleName + , moduleString -- :: ModuleName -> EncodedString + , moduleUserString -- :: ModuleName -> UserString + , moduleFS -- :: ModuleName -> EncodedFS - , pprModule, pprModuleName + , mkModule -- :: UserString -> ModuleName + , mkModuleFS -- :: UserFS -> ModuleName + , mkSysModuleFS -- :: EncodedFS -> ModuleName - , PackageName + , ModuleEnv, + , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C + , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv + , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv + , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv + , extendModuleEnv_C, filterModuleEnv, - -- Where to find a .hi file - , WhereFrom(..), SearchPath, mkSearchPath - , ModuleHiMap, mkModuleHiMaps + , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet ) where #include "HsVersions.h" import OccName import Outputable -import FiniteMap -import CmdLineOpts ( opt_Static, opt_InPackage, opt_WarnHiShadows, opt_HiMapSep ) -import Constants ( interfaceFileFormatVersion ) -import Maybes ( seqMaybe ) -import Maybe ( fromMaybe ) -import Directory ( doesFileExist ) -import DirUtils ( getDirectoryContents ) -import List ( intersperse ) -import Monad ( foldM ) -import IO ( hPutStrLn, stderr, isDoesNotExistError ) -import FastString ( FastString ) +import Unique ( Uniquable(..) ) +import UniqFM +import UniqSet +import Binary +import FastString \end{code} - %************************************************************************ %* * -\subsection{Interface file flavour} +\subsection{Module locations} %* * %************************************************************************ -A further twist to the tale is the support for dynamically linked libraries under -Win32. Here, dealing with the use of global variables that's residing in a DLL -requires special handling at the point of use (there's an extra level of indirection, -i.e., (**v) to get at v's value, rather than just (*v) .) When slurping in an -interface file we then record whether it's coming from a .hi corresponding to a -module that's packaged up in a DLL or not, so that we later can emit the -appropriate code. - -The logic for how an interface file is marked as corresponding to a module that's -hiding in a DLL is explained elsewhere (ToDo: give renamer href here.) - \begin{code} -data PackageInfo = ThisPackage -- A module from the same package - -- as the one being compiled - | AnotherPackage PackageName -- A module from a different package - -type PackageName = FastString -- No encoding at all - -preludePackage :: PackageName -preludePackage = SLIT("std") - -instance Show PackageInfo where -- Just used in debug prints of lex tokens - -- and in debug modde - showsPrec n ThisPackage s = "" ++ s - showsPrec n (AnotherPackage p) s = (_UNPK_ p) ++ s +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + -- The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file :: FilePath, + -- Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_obj_file :: FilePath + -- Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- package with a .a file) + } deriving Show + +instance Outputable ModLocation where + ppr = text . show \end{code} +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. -%************************************************************************ -%* * -\subsection{Where from} -%* * -%************************************************************************ - -The @WhereFrom@ type controls where the renamer looks for an interface file +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. \begin{code} -data WhereFrom = ImportByUser -- Ordinary user import: look for M.hi - | ImportByUserSource -- User {- SOURCE -}: look for M.hi-boot - | ImportBySystem -- Non user import. Look for M.hi if M is in - -- the module this module depends on, or is a system-ish module; - -- M.hi-boot otherwise - -instance Outputable WhereFrom where - ppr ImportByUser = empty - ppr ImportByUserSource = ptext SLIT("{- SOURCE -}") - ppr ImportBySystem = ptext SLIT("{- SYSTEM IMPORT -}") +addBootSuffix :: FilePath -> FilePath +-- Add the "-boot" suffix to .hs, .hi and .o files +addBootSuffix path = path ++ "-boot" + +addBootSuffix_maybe :: Bool -> FilePath -> FilePath +addBootSuffix_maybe is_boot path + | is_boot = addBootSuffix path + | otherwise = path + +addBootSuffixLocn :: ModLocation -> ModLocation +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) } \end{code} @@ -133,231 +108,116 @@ instance Outputable WhereFrom where %************************************************************************ \begin{code} -type ModuleName = EncodedFS +newtype Module = Module EncodedFS -- Haskell module names can include the quote character ', -- so the module names have the z-encoding applied to them -pprModuleName :: ModuleName -> SDoc -pprModuleName nm = pprEncodedFS nm - -moduleNameString :: ModuleName -> EncodedString -moduleNameString mod = _UNPK_ mod - -moduleNameUserString :: ModuleName -> UserString -moduleNameUserString mod = decode (_UNPK_ mod) - -mkSrcModule :: UserString -> ModuleName -mkSrcModule s = _PK_ (encode s) +instance Binary Module where + put_ bh (Module m) = put_ bh m + get bh = do m <- get bh; return (Module m) -mkSrcModuleFS :: UserFS -> ModuleName -mkSrcModuleFS s = encodeFS s +instance Uniquable Module where + getUnique (Module nm) = getUnique nm -mkSysModuleFS :: EncodedFS -> ModuleName -mkSysModuleFS s = s -\end{code} +instance Eq Module where + nm1 == nm2 = getUnique nm1 == getUnique nm2 -\begin{code} -data Module = Module ModuleName PackageInfo -\end{code} +-- Warning: gives an ordering relation based on the uniques of the +-- FastStrings which are the (encoded) module names. This is _not_ +-- a lexicographical ordering. +instance Ord Module where + nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -\begin{code} instance Outputable Module where ppr = pprModule -instance Eq Module where - (Module m1 _) == (Module m2 _) = m1 == m2 - -instance Ord Module where - (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2 -\end{code} - -\begin{code} pprModule :: Module -> SDoc -pprModule (Module mod p) = getPprStyle $ \ sty -> - if debugStyle sty then - -- Print the package too - text (show p) <> dot <> pprModuleName mod - else - pprModuleName mod -\end{code} +pprModule (Module nm) = pprEncodedFS nm - -\begin{code} -mkModule :: ModuleName -- Name of the module - -> PackageName - -> Module -mkModule mod_nm pack_name - = Module mod_nm pack_info - where - pack_info | pack_name == opt_InPackage = ThisPackage - | otherwise = AnotherPackage pack_name - - -mkVanillaModule :: ModuleName -> Module -mkVanillaModule name = Module name ThisPackage - -- Used temporarily when we first come across Foo.x in an interface - -- file, but before we've opened Foo.hi. - -- (Until we've opened Foo.hi we don't know what the PackageInfo is.) - -mkThisModule :: ModuleName -> Module -- The module being compiled -mkThisModule name = Module name ThisPackage - -mkPrelModule :: ModuleName -> Module -mkPrelModule name = mkModule name preludePackage +moduleFS :: Module -> EncodedFS +moduleFS (Module mod) = mod moduleString :: Module -> EncodedString -moduleString (Module mod _) = _UNPK_ mod - -moduleName :: Module -> ModuleName -moduleName (Module mod _) = mod +moduleString (Module mod) = unpackFS mod moduleUserString :: Module -> UserString -moduleUserString (Module mod _) = moduleNameUserString mod -\end{code} +moduleUserString (Module mod) = decode (unpackFS mod) -\begin{code} -isLocalModule :: Module -> Bool -isLocalModule (Module _ ThisPackage) = True -isLocalModule _ = False -\end{code} +-- used to be called mkSrcModule +mkModule :: UserString -> Module +mkModule s = Module (mkFastString (encode s)) +-- used to be called mkSrcModuleFS +mkModuleFS :: UserFS -> Module +mkModuleFS s = Module (encodeFS s) -%************************************************************************ -%* * -\subsection{Finding modules in the file system -%* * -%************************************************************************ - -\begin{code} -type ModuleHiMap = FiniteMap ModuleName String - -- Mapping from module name to - -- * the file path of its corresponding interface file, - -- * the ModuleName +-- used to be called mkSysModuleFS +mkSysModuleFS :: EncodedFS -> Module +mkSysModuleFS s = Module s \end{code} -(We allege that) it is quicker to build up a mapping from module names -to the paths to their corresponding interface files once, than to search -along the import part every time we slurp in a new module (which we -do quite a lot of.) +%************************************************************************ +%* * +\subsection{@ModuleEnv@s} +%* * +%************************************************************************ \begin{code} -type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search - -- for interface files. - -mkModuleHiMaps :: SearchPath -> IO (SearchPath, ModuleHiMap, ModuleHiMap) -mkModuleHiMaps dirs = do (hi,hi_boot) <- foldM (getAllFilesMatching dirs) (env,env) dirs - return (dirs, hi, hi_boot) - 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) filename = fromMaybe his $ - FMAP add_hi (go xiffus rev_fname) `seqMaybe` - - FMAP add_vhib (go hi_boot_version_xiffus rev_fname) `seqMaybe` - -- If there's a Foo.hi-boot-N file then override any Foo.hi-boot - - FMAP add_hib (go hi_boot_xiffus rev_fname) - where - rev_fname = reverse filename - path = dir_path ++ '/':filename - - -- In these functions file_nm is the base of the filename, - -- with the path and suffix both stripped off. The filename - -- is the *unencoded* module name (else 'make' gets confused). - -- But the domain of the HiMaps is ModuleName which is encoded. - add_hi file_nm = (add_to_map addNewOne hi_env file_nm, hib_env) - add_vhib file_nm = (hi_env, add_to_map overrideNew hib_env file_nm) - add_hib file_nm = (hi_env, add_to_map addNewOne hib_env file_nm) - - add_to_map combiner env file_nm - = addToFM_C combiner env mod_nm path - where - mod_nm = mkSrcModuleFS file_nm - - -- go prefix (prefix ++ stuff) == Just (reverse stuff) - go [] xs = Just (_PK_ (reverse xs)) - 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 the 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. +type ModuleEnv elt = UniqFM elt + +emptyModuleEnv :: ModuleEnv a +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +unitModuleEnv :: Module -> a -> ModuleEnv a +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv_C :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +moduleEnvElts :: ModuleEnv a -> [a] + +isEmptyModuleEnv :: ModuleEnv a -> Bool +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +elemModuleEnv :: Module -> ModuleEnv a -> Bool +foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b +filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a + +filterModuleEnv = filterUFM +elemModuleEnv = elemUFM +extendModuleEnv = addToUFM +extendModuleEnv_C = addToUFM_C +extendModuleEnvList = addListToUFM +plusModuleEnv_C = plusUFM_C +delModuleEnvList = delListFromUFM +delModuleEnv = delFromUFM +plusModuleEnv = plusUFM +lookupModuleEnv = lookupUFM +lookupWithDefaultModuleEnv = lookupWithDefaultUFM +mapModuleEnv = mapUFM +mkModuleEnv = listToUFM +emptyModuleEnv = emptyUFM +moduleEnvElts = eltsUFM +unitModuleEnv = unitUFM +isEmptyModuleEnv = isNullUFM +foldModuleEnv = foldUFM \end{code} - -%********************************************************* -%* * -\subsection{Making a search path} -%* * -%********************************************************* - -@mkSearchPath@ takes a string consisting of a colon-separated list -of directories and corresponding suffixes, and turns it into a list -of (directory, suffix) pairs. For example: - -\begin{verbatim} - mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi" - = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")] -\begin{verbatim} - \begin{code} -mkSearchPath :: Maybe String -> SearchPath -mkSearchPath Nothing = [(".",".hi")] -- ToDo: default should be to look in - -- the directory the module we're compiling - -- lives. -mkSearchPath (Just s) = go s - where - go "" = [] - go s = - case span (/= '%') s of - (dir,'%':rs) -> - case span (/= opt_HiMapSep) rs of - (hisuf,_:rest) -> (dir,hisuf):go rest - (hisuf,[]) -> [(dir,hisuf)] +type ModuleSet = UniqSet Module +mkModuleSet :: [Module] -> ModuleSet +extendModuleSet :: ModuleSet -> Module -> ModuleSet +emptyModuleSet :: ModuleSet +moduleSetElts :: ModuleSet -> [Module] +elemModuleSet :: Module -> ModuleSet -> Bool + +emptyModuleSet = emptyUniqSet +mkModuleSet = mkUniqSet +extendModuleSet = addOneToUniqSet +moduleSetElts = uniqSetToList +elemModuleSet = elementOfUniqSet \end{code} -