X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FModule.lhs;h=89b3eddfd71b1ff73fe8d9db0cb4c2090f62c9de;hp=69521625b0568008780b72371c579ef7d8a6cc32;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index 6952162..89b3edd 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -1,46 +1,89 @@
 %
-% (c) The University of Glasgow, 2004
+% (c) The University of Glasgow, 2004-2006
 %
 
 Module
 ~~~~~~~~~~
 Simply the name of a module, represented as a FastString.
-These are Uniquable, hence we can build FiniteMaps with ModuleNames as
+These are Uniquable, hence we can build Maps with Modules as
 the keys.
 
 \begin{code}
 module Module 
     (
-      Module 		   	-- Abstract, instance of Eq, Ord, Outputable
-    , pprModule			-- :: ModuleName -> SDoc
-
-    , ModLocation(..)
-    , addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn
-
-    , moduleString		-- :: ModuleName -> String
-    , moduleFS			-- :: ModuleName -> FastString
-
-    , mkModule			-- :: String -> ModuleName
-    , mkModuleFS		-- :: FastString -> ModuleName
- 
-    , ModuleEnv
-    , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C
-    , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
-    , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
-    , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
-    , extendModuleEnv_C, filterModuleEnv
-
-    , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
-
+	-- * The ModuleName type
+	ModuleName,
+	pprModuleName,
+	moduleNameFS,
+	moduleNameString,
+        moduleNameSlashes,
+	mkModuleName,
+	mkModuleNameFS,
+	stableModuleNameCmp,
+
+        -- * The PackageId type
+        PackageId,
+        fsToPackageId,
+        packageIdFS,
+        stringToPackageId,
+        packageIdString,
+	stablePackageIdCmp,
+
+	-- * Wired-in PackageIds
+	-- $wired_in_packages
+	primPackageId,
+	integerPackageId,
+	basePackageId,
+	rtsPackageId,
+	thPackageId,
+        dphSeqPackageId,
+        dphParPackageId,
+	mainPackageId,
+
+	-- * The Module type
+	Module,
+	modulePackageId, moduleName,
+	pprModule,
+	mkModule,
+        stableModuleCmp,
+
+	-- * The ModuleLocation type
+	ModLocation(..),
+	addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
+
+	-- * Module mappings
+    	ModuleEnv,
+	elemModuleEnv, extendModuleEnv, extendModuleEnvList, 
+	extendModuleEnvList_C, plusModuleEnv_C,
+	delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
+	lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
+	moduleEnvKeys, moduleEnvElts, moduleEnvToList,
+        unitModuleEnv, isEmptyModuleEnv,
+        foldModuleEnv, extendModuleEnvWith, filterModuleEnv,
+
+	-- * ModuleName mappings
+	ModuleNameEnv,
+
+	-- * Sets of Modules
+	ModuleSet, 
+	emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
     ) where
 
-#include "HsVersions.h"
+#include "Typeable.h"
+
+import Config
 import Outputable
-import Unique		( Uniquable(..) )
+import Unique
 import UniqFM
-import UniqSet
-import Binary
 import FastString
+import Binary
+import Util
+
+import Data.Data
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+import System.FilePath
 \end{code}
 
 %************************************************************************
@@ -50,6 +93,8 @@ import FastString
 %************************************************************************
 
 \begin{code}
+-- | Where a module lives on the file system: the actual locations
+-- of the .hs, .hi and .o files, if we have them
 data ModLocation
    = ModLocation {
         ml_hs_file   :: Maybe FilePath,
@@ -82,15 +127,17 @@ where the object file will reside if/when it is created.
 
 \begin{code}
 addBootSuffix :: FilePath -> FilePath
--- Add the "-boot" suffix to .hs, .hi and .o files
+-- ^ Add the @-boot@ suffix to .hs, .hi and .o files
 addBootSuffix path = path ++ "-boot"
 
 addBootSuffix_maybe :: Bool -> FilePath -> FilePath
+-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@
 addBootSuffix_maybe is_boot path
  | is_boot   = addBootSuffix path
  | otherwise = path
 
 addBootSuffixLocn :: ModLocation -> ModLocation
+-- ^ Add the @-boot@ suffix to all file paths associated with the module
 addBootSuffixLocn locn
   = locn { ml_hs_file  = fmap addBootSuffix (ml_hs_file locn)
 	 , ml_hi_file  = addBootSuffix (ml_hi_file locn)
@@ -105,49 +152,209 @@ addBootSuffixLocn locn
 %************************************************************************
 
 \begin{code}
-newtype Module = Module FastString
-	-- Haskell module names can include the quote character ',
-	-- so the module names have the z-encoding applied to them
+-- | A ModuleName is essentially a simple string, e.g. @Data.List@.
+newtype ModuleName = ModuleName FastString
+    deriving Typeable
 
-instance Binary Module where
-   put_ bh (Module m) = put_ bh m
-   get bh = do m <- get bh; return (Module m)
+instance Uniquable ModuleName where
+  getUnique (ModuleName nm) = getUnique nm
 
-instance Uniquable Module where
-  getUnique (Module nm) = getUnique nm
-
-instance Eq Module where
+instance Eq ModuleName where
   nm1 == nm2 = getUnique nm1 == getUnique nm2
 
 -- 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
+instance Ord ModuleName where
   nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
 
-instance Outputable Module where
-  ppr = pprModule
+instance Outputable ModuleName where
+  ppr = pprModuleName
 
-pprModule :: Module -> SDoc
-pprModule (Module nm) = 
+instance Binary ModuleName where
+  put_ bh (ModuleName fs) = put_ bh fs
+  get bh = do fs <- get bh; return (ModuleName fs)
+
+instance Data ModuleName where
+  -- don't traverse?
+  toConstr _   = abstractConstr "ModuleName"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "ModuleName"
+
+stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
+-- ^ Compares module names lexically, rather than by their 'Unique's
+stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
+
+pprModuleName :: ModuleName -> SDoc
+pprModuleName (ModuleName nm) = 
     getPprStyle $ \ sty ->
     if codeStyle sty 
 	then ftext (zEncodeFS nm)
 	else ftext nm
 
-moduleFS :: Module -> FastString
-moduleFS (Module mod) = mod
+moduleNameFS :: ModuleName -> FastString
+moduleNameFS (ModuleName mod) = mod
+
+moduleNameString :: ModuleName -> String
+moduleNameString (ModuleName mod) = unpackFS mod
+
+mkModuleName :: String -> ModuleName
+mkModuleName s = ModuleName (mkFastString s)
+
+mkModuleNameFS :: FastString -> ModuleName
+mkModuleNameFS s = ModuleName s
+
+-- | Returns the string version of the module name, with dots replaced by slashes
+moduleNameSlashes :: ModuleName -> String
+moduleNameSlashes = dots_to_slashes . moduleNameString
+  where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{A fully qualified module}
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | A Module is a pair of a 'PackageId' and a 'ModuleName'.
+data Module = Module {
+   modulePackageId :: !PackageId,  -- pkg-1.0
+   moduleName      :: !ModuleName  -- A.B.C
+  }
+  deriving (Eq, Ord, Typeable)
+
+instance Uniquable Module where
+  getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n)
+
+instance Outputable Module where
+  ppr = pprModule
+
+instance Binary Module where
+  put_ bh (Module p n) = put_ bh p >> put_ bh n
+  get bh = do p <- get bh; n <- get bh; return (Module p n)
+
+instance Data Module where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Module"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "Module"
+
+-- | This gives a stable ordering, as opposed to the Ord instance which
+-- gives an ordering based on the 'Unique's of the components, which may
+-- not be stable from run to run of the compiler.
+stableModuleCmp :: Module -> Module -> Ordering
+stableModuleCmp (Module p1 n1) (Module p2 n2) 
+   = (p1 `stablePackageIdCmp`  p2) `thenCmp`
+     (n1 `stableModuleNameCmp` n2)
+
+mkModule :: PackageId -> ModuleName -> Module
+mkModule = Module
+
+pprModule :: Module -> SDoc
+pprModule mod@(Module p n)  =
+  pprPackagePrefix p mod <> pprModuleName n
+
+pprPackagePrefix :: PackageId -> Module -> SDoc
+pprPackagePrefix p mod = getPprStyle doc
+ where
+   doc sty
+       | codeStyle sty = 
+          if p == mainPackageId 
+                then empty -- never qualify the main package in code
+                else ftext (zEncodeFS (packageIdFS p)) <> char '_'
+       | qualModule sty mod = ftext (packageIdFS (modulePackageId mod)) <> char ':'
+                -- the PrintUnqualified tells us which modules have to
+                -- be qualified with package names
+       | otherwise = empty
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+\subsection{PackageId}
+%*                                                                      *
+%************************************************************************
 
-moduleString :: Module -> String
-moduleString (Module mod) = unpackFS mod
+\begin{code}
+-- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0
+newtype PackageId = PId FastString deriving( Eq, Typeable )
+    -- here to avoid module loops with PackageConfig
 
--- used to be called mkSrcModule
-mkModule :: String -> Module
-mkModule s = Module (mkFastString s)
+instance Uniquable PackageId where
+ getUnique pid = getUnique (packageIdFS pid)
 
--- used to be called mkSrcModuleFS
-mkModuleFS :: FastString -> Module
-mkModuleFS s = Module s
+-- Note: *not* a stable lexicographic ordering, a faster unique-based
+-- ordering.
+instance Ord PackageId where
+  nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
+
+instance Data PackageId where
+  -- don't traverse?
+  toConstr _   = abstractConstr "PackageId"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "PackageId"
+
+stablePackageIdCmp :: PackageId -> PackageId -> Ordering
+-- ^ Compares package ids lexically, rather than by their 'Unique's
+stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2
+
+instance Outputable PackageId where
+   ppr pid = text (packageIdString pid)
+
+instance Binary PackageId where
+  put_ bh pid = put_ bh (packageIdFS pid)
+  get bh = do { fs <- get bh; return (fsToPackageId fs) }
+
+fsToPackageId :: FastString -> PackageId
+fsToPackageId = PId
+
+packageIdFS :: PackageId -> FastString
+packageIdFS (PId fs) = fs
+
+stringToPackageId :: String -> PackageId
+stringToPackageId = fsToPackageId . mkFastString
+
+packageIdString :: PackageId -> String
+packageIdString = unpackFS . packageIdFS
+
+
+-- -----------------------------------------------------------------------------
+-- $wired_in_packages
+-- Certain packages are known to the compiler, in that we know about certain
+-- entities that reside in these packages, and the compiler needs to 
+-- declare static Modules and Names that refer to these packages.  Hence
+-- the wired-in packages can't include version numbers, since we don't want
+-- to bake the version numbers of these packages into GHC.
+--
+-- So here's the plan.  Wired-in packages are still versioned as
+-- normal in the packages database, and you can still have multiple
+-- versions of them installed.  However, for each invocation of GHC,
+-- only a single instance of each wired-in package will be recognised
+-- (the desired one is selected via @-package@\/@-hide-package@), and GHC
+-- will use the unversioned 'PackageId' below when referring to it,
+-- including in .hi files and object file symbols.  Unselected
+-- versions of wired-in packages will be ignored, as will any other
+-- package that depends directly or indirectly on it (much as if you
+-- had used @-ignore-package@).
+
+-- Make sure you change 'Packages.findWiredInPackages' if you add an entry here
+
+integerPackageId, primPackageId,
+  basePackageId, rtsPackageId,
+  thPackageId, dphSeqPackageId, dphParPackageId,
+  mainPackageId  :: PackageId
+primPackageId      = fsToPackageId (fsLit "ghc-prim")
+integerPackageId   = fsToPackageId (fsLit cIntegerLibrary)
+basePackageId      = fsToPackageId (fsLit "base")
+rtsPackageId       = fsToPackageId (fsLit "rts")
+thPackageId        = fsToPackageId (fsLit "template-haskell")
+dphSeqPackageId    = fsToPackageId (fsLit "dph-seq")
+dphParPackageId    = fsToPackageId (fsLit "dph-par")
+
+-- | This is the package Id for the current program.  It is the default
+-- package Id if you don't specify a package name.  We don't add this prefix
+-- to symbol names, since there can be only one main package per program.
+mainPackageId	   = fsToPackageId (fsLit "main")
 \end{code}
 
 %************************************************************************
@@ -157,60 +364,95 @@ mkModuleFS s = Module s
 %************************************************************************
 
 \begin{code}
-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
+-- | A map keyed off of 'Module's
+newtype ModuleEnv elt = ModuleEnv (Map Module elt)
+
+filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
+filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey f e)
+
+elemModuleEnv :: Module -> ModuleEnv a -> Bool
+elemModuleEnv m (ModuleEnv e) = Map.member m e
+
+extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a
+extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert m x e)
+
+extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
+extendModuleEnvWith f (ModuleEnv e) m x = ModuleEnv (Map.insertWith f m x e)
+
+extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a
+extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (Map.insertList xs e)
+
+extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)]
+                      -> ModuleEnv a
+extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (Map.insertListWith f xs e)
+
+plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
+plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.unionWith f e1 e2)
+
+delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
+delModuleEnvList (ModuleEnv e) ms = ModuleEnv (Map.deleteList ms e)
+
+delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
+delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete m e)
+
+plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a
+plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2)
+
+lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
+lookupModuleEnv (ModuleEnv e) m = Map.lookup m e
+
 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
+lookupWithDefaultModuleEnv (ModuleEnv e) x m = Map.findWithDefault x m e
+
+mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
+mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e)
+
+mkModuleEnv :: [(Module, a)] -> ModuleEnv a
+mkModuleEnv xs = ModuleEnv (Map.fromList xs)
+
+emptyModuleEnv :: ModuleEnv a
+emptyModuleEnv = ModuleEnv Map.empty
+
+moduleEnvKeys :: ModuleEnv a -> [Module]
+moduleEnvKeys (ModuleEnv e) = Map.keys e
+
+moduleEnvElts :: ModuleEnv a -> [a]
+moduleEnvElts (ModuleEnv e) = Map.elems e
+
+moduleEnvToList :: ModuleEnv a -> [(Module, a)]
+moduleEnvToList (ModuleEnv e) = Map.toList e
+
+unitModuleEnv :: Module -> a -> ModuleEnv a
+unitModuleEnv m x = ModuleEnv (Map.singleton m x)
+
+isEmptyModuleEnv :: ModuleEnv a -> Bool
+isEmptyModuleEnv (ModuleEnv e) = Map.null e
+
+foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
+foldModuleEnv f x (ModuleEnv e) = Map.foldRightWithKey (\_ v -> f v) x e
 \end{code}
 
 \begin{code}
-type ModuleSet = UniqSet Module
+-- | A set of 'Module's
+type ModuleSet = Map 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
+emptyModuleSet    = Map.empty
+mkModuleSet ms    = Map.fromList [(m,()) | m <- ms ]
+extendModuleSet s m = Map.insert m () s
+moduleSetElts     = Map.keys
+elemModuleSet     = Map.member
+\end{code}
+
+A ModuleName has a Unique, so we can build mappings of these using
+UniqFM.
+
+\begin{code}
+-- | A map keyed off of 'ModuleName's (actually, their 'Unique's)
+type ModuleNameEnv elt = UniqFM elt
 \end{code}