X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FModule.lhs;h=57509a00fed8049d4bcdb24393ea871de7a2b6d6;hp=f6b8b8342a7021e93e2cc09e3682567011b9825f;hb=48b6c777e2e84cc42a27a50642bcb41a0bd2c1d7;hpb=1a7d1b77334529ca96ed4cbc03fcb5f55dc2de4a

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index f6b8b83..57509a0 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -16,8 +16,10 @@ module Module
 	pprModuleName,
 	moduleNameFS,
 	moduleNameString,
+        moduleNameSlashes,
 	mkModuleName,
 	mkModuleNameFS,
+	stableModuleNameCmp,
 
         -- * The PackageId type
         PackageId,
@@ -25,13 +27,18 @@ module Module
         packageIdFS,
         stringToPackageId,
         packageIdString,
+	stablePackageIdCmp,
 
 	-- * Wired-in PackageIds
+	primPackageId,
+	integerPackageId,
 	basePackageId,
 	rtsPackageId,
 	haskell98PackageId,
 	thPackageId,
         ndpPackageId,
+        dphSeqPackageId,
+        dphParPackageId,
 	mainPackageId,
 
 	-- * The Module type
@@ -39,6 +46,7 @@ module Module
 	modulePackageId, moduleName,
 	pprModule,
 	mkModule,
+        stableModuleCmp,
 
 	-- * The ModuleLocation type
 	ModLocation(..),
@@ -50,8 +58,8 @@ module Module
 	extendModuleEnvList_C, plusModuleEnv_C,
 	delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv,
 	lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv,
-	moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv,
-	extendModuleEnv_C, filterModuleEnv,
+	moduleEnvKeys, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv,
+        foldModuleEnv, extendModuleEnv_C, filterModuleEnv,
 
 	-- * ModuleName mappings
 	ModuleNameEnv,
@@ -61,14 +69,16 @@ module Module
 	elemModuleSet
     ) where
 
-#include "HsVersions.h"
 import Outputable
 import qualified Pretty
 import Unique
 import FiniteMap
-import UniqFM
+import LazyUniqFM
 import FastString
 import Binary
+import Util
+
+import System.FilePath
 \end{code}
 
 %************************************************************************
@@ -155,6 +165,10 @@ instance Binary ModuleName where
   put_ bh (ModuleName fs) = put_ bh fs
   get bh = do fs <- get bh; return (ModuleName fs)
 
+stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering
+-- Compare lexically, not by unique
+stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2
+
 pprModuleName :: ModuleName -> SDoc
 pprModuleName (ModuleName nm) = 
     getPprStyle $ \ sty ->
@@ -173,6 +187,11 @@ 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}
 
 %************************************************************************
@@ -196,8 +215,13 @@ 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 Uniquable PackageId where
- getUnique pid = getUnique (packageIdFS pid)
+-- This gives a stable ordering, as opposed to the Ord instance which
+-- gives an ordering based on the Uniques 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
@@ -226,9 +250,20 @@ pprPackagePrefix p mod = getPprStyle doc
 %************************************************************************
 
 \begin{code}
-newtype PackageId = PId FastString deriving( Eq, Ord )  -- includes the version
+newtype PackageId = PId FastString deriving( Eq )  -- includes the version
     -- here to avoid module loops with PackageConfig
 
+instance Uniquable PackageId where
+ getUnique pid = getUnique (packageIdFS pid)
+
+-- Note: *not* a stable lexicographic ordering, a faster unique-based
+-- ordering.
+instance Ord PackageId where
+  nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
+
+stablePackageIdCmp :: PackageId -> PackageId -> Ordering
+stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2
+
 instance Outputable PackageId where
    ppr pid = text (packageIdString pid)
 
@@ -269,18 +304,23 @@ packageIdString = unpackFS . packageIdFS
 -- package that depends directly or indirectly on it (much as if you
 -- had used -ignore-package).
 
-basePackageId, rtsPackageId, haskell98PackageId, 
+integerPackageId, primPackageId,
+  basePackageId, rtsPackageId, haskell98PackageId,
   thPackageId, ndpPackageId, mainPackageId  :: PackageId
-basePackageId      = fsToPackageId FSLIT("base")
-rtsPackageId	   = fsToPackageId FSLIT("rts")
-haskell98PackageId = fsToPackageId FSLIT("haskell98")
-thPackageId        = fsToPackageId FSLIT("template-haskell")
-ndpPackageId       = fsToPackageId FSLIT("ndp")
+primPackageId      = fsToPackageId (fsLit "ghc-prim")
+integerPackageId   = fsToPackageId (fsLit "integer")
+basePackageId      = fsToPackageId (fsLit "base")
+rtsPackageId	   = fsToPackageId (fsLit "rts")
+haskell98PackageId = fsToPackageId (fsLit "haskell98")
+thPackageId        = fsToPackageId (fsLit "template-haskell")
+ndpPackageId       = fsToPackageId (fsLit "ndp")
+dphSeqPackageId    = fsToPackageId (fsLit "dph-seq")
+dphParPackageId    = fsToPackageId (fsLit "dph-par")
 
 -- This is the package Id for the program.  It is the default package
 -- Id if you don't specify a package name.  We don't add this prefix
 -- to symbol name, since there can be only one main package per program.
-mainPackageId	   = fsToPackageId FSLIT("main")
+mainPackageId	   = fsToPackageId (fsLit "main")
 \end{code}
 
 %************************************************************************
@@ -305,6 +345,7 @@ 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
+moduleEnvKeys        :: ModuleEnv a -> [Module]
 moduleEnvElts        :: ModuleEnv a -> [a]
                   
 isEmptyModuleEnv     :: ModuleEnv a -> Bool
@@ -329,6 +370,7 @@ lookupWithDefaultModuleEnv = lookupWithDefaultFM
 mapModuleEnv f      = mapFM (\_ v -> f v)
 mkModuleEnv         = listToFM
 emptyModuleEnv      = emptyFM
+moduleEnvKeys       = keysFM
 moduleEnvElts       = eltsFM
 unitModuleEnv       = unitFM
 isEmptyModuleEnv    = isEmptyFM