Tweak layout for alternative layout rule

[ghc-hetmet.git] / compiler / main / Packages.lhs

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 077a4eb..f6ba7c1 100644 (file)
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -557,11 +557,12 @@ shadowPackages pkgs preferred
  where
  check (shadowed,pkgmap) pkg
       | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
-      = let
-          ipid_new = installedPackageId pkg
-          ipid_old = installedPackageId oldpkg
-        in
-        if ipid_old `elem` preferred
+      , let
+            ipid_new = installedPackageId pkg
+            ipid_old = installedPackageId oldpkg
+        --
+      , ipid_old /= ipid_new
+      = if ipid_old `elem` preferred
            then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap )
            else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' )
       | otherwise
@@ -657,6 +658,14 @@ mkPackageState dflags pkgs0 preload0 this_package = do
 
       ipid_map = listToFM [ (installedPackageId p, p) | p <- pkgs0 ]
 
+      -- pkgs0 with duplicate packages filtered out.  This is
+      -- important: it is possible for a package in the user package
+      -- DB to have the same IPID as a package in the global DB, and
+      -- we want the former to take precedence.  This is not the same
+      -- as shadowing (below), since in this case the two packages
+      -- have the same ABI and are interchangeable.
+      pkgs0_unique = eltsFM ipid_map
+
       ipid_selected = depClosure ipid_map [ InstalledPackageId i
                                           | ExposePackageId i <- flags ]
       
@@ -664,11 +673,11 @@ mkPackageState dflags pkgs0 preload0 this_package = do
       is_ignore IgnorePackage{} = True
       is_ignore _ = False
 
-      shadowed = shadowPackages pkgs0 ipid_selected
+      shadowed = shadowPackages pkgs0_unique ipid_selected
 
-      ignored  = ignorePackages ignore_flags pkgs0
+      ignored  = ignorePackages ignore_flags pkgs0_unique
 
-      pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0
+      pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0_unique
       broken   = findBroken pkgs0'
       unusable = shadowed `plusFM` ignored `plusFM` broken
 
@@ -678,7 +687,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
   -- Modify the package database according to the command-line flags
   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
   --
-  pkgs1 <- foldM (applyPackageFlag unusable) pkgs0 other_flags
+  pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
   let pkgs2 = filter (not . (`elemFM` unusable) . installedPackageId) pkgs1
 
   -- Here we build up a set of the packages mentioned in -package
@@ -801,12 +810,20 @@ collectLinkOpts dflags ps = concat (map all_opts ps)
 packageHsLibs :: DynFlags -> PackageConfig -> [String]
 packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
   where
-        non_dyn_ways = filter ((/= WayDyn) . wayName) (ways dflags)
+        ways0 = ways dflags
+
+        ways1 = filter ((/= WayDyn) . wayName) ways0
         -- the name of a shared library is libHSfoo-ghc<version>.so
         -- we leave out the _dyn, because it is superfluous
 
-        tag     = mkBuildTag (filter (not . wayRTSOnly) non_dyn_ways)
-        rts_tag = mkBuildTag non_dyn_ways
+        -- debug RTS includes support for -eventlog
+        ways2 | WayDebug `elem` map wayName ways1 
+              = filter ((/= WayEventLog) . wayName) ways1
+              | otherwise
+              = ways1
+
+        tag     = mkBuildTag (filter (not . wayRTSOnly) ways2)
+        rts_tag = mkBuildTag ways2
 
        mkDynName | opt_Static = id
                  | otherwise = (++ ("-ghc" ++ cProjectVersion))