Hadrian: use a set to keep track of ways

The order in which ways are provided doesn't matter,
so we use a data structure with the appropriate semantics to
represent ways.

Fixes #21378

18 files changed, 68 insertions, 33 deletions

diff --git a/hadrian/src/Expression/Type.hs b/hadrian/src/Expression/Type.hs
index b5b0138f0a..cf6eec2129 100644
--- a/hadrian/src/Expression/Type.hs
+++ b/hadrian/src/Expression/Type.hs
@@ -1,5 +1,6 @@
 module Expression.Type where
 
+import Data.Set (Set)
 import Context.Type
 import Way.Type
 
@@ -15,4 +16,4 @@ type Expr a = H.Expr Context Builder a
 -- and 'Packages'.
 type Predicate = H.Predicate Context Builder
 type Args      = H.Args      Context Builder
-type Ways      = Expr [Way]
+type Ways      = Expr (Set Way)
diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs
index 41c86de5ff..a3b93f6094 100644
--- a/hadrian/src/Flavour.hs
+++ b/hadrian/src/Flavour.hs
@@ -21,6 +21,7 @@ import Expression
 import Data.Either
 import Data.Map (Map)
 import qualified Data.Map as M
+import qualified Data.Set as Set
 import Packages
 import Flavour.Type
 import Settings.Parser
@@ -173,7 +174,7 @@ enableProfiledGhc flavour =
   where
     addWays :: [Way] -> Ways -> Ways
     addWays ways =
-      fmap (++ ways)
+      fmap (Set.union (Set.fromList ways))
 
 -- | Disable 'dynamicGhcPrograms'.
 disableDynamicGhcPrograms :: Flavour -> Flavour
@@ -187,7 +188,7 @@ disableProfiledLibs flavour =
             }
   where
     prune :: Ways -> Ways
-    prune = fmap $ filter (not . wayUnit Profiling)
+    prune = fmap $ Set.filter (not . wayUnit Profiling)
 
 -- | Build stage2 compiler with -fomit-interface-pragmas to reduce
 -- recompilation.
@@ -224,7 +225,7 @@ fullyStatic flavour =
   where
     -- Remove any Way that contains a WayUnit of Dynamic
     prune :: Ways -> Ways
-    prune = fmap $ filter staticCompatible
+    prune = fmap $ Set.filter staticCompatible
 
     staticCompatible :: Way -> Bool
     staticCompatible = not . wayUnit Dynamic
diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index fc85d1d698..521c0ac154 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -1,6 +1,8 @@
 module Rules (buildRules, oracleRules, packageTargets, topLevelTargets
              , toolArgsTarget ) where
 
+import qualified Data.Set as Set
+
 import qualified Hadrian.Oracles.ArgsHash
 import qualified Hadrian.Oracles.Cabal.Rules
 import qualified Hadrian.Oracles.DirectoryContents
@@ -90,7 +92,7 @@ packageTargets includeGhciLib stage pkg = do
         then do -- Collect all targets of a library package.
             let pkgWays = if pkg == rts then getRtsWays else getLibraryWays
             ways  <- interpretInContext context pkgWays
-            libs  <- mapM (pkgLibraryFile . Context stage pkg) ways
+            libs  <- mapM (pkgLibraryFile . Context stage pkg) (Set.toList ways)
             more  <- Rules.Library.libraryTargets includeGhciLib context
             setupConfig <- pkgSetupConfigFile context
             return $ [setupConfig] ++ libs ++ more
diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs
index db220a98c4..912618662e 100644
--- a/hadrian/src/Rules/Generate.hs
+++ b/hadrian/src/Rules/Generate.hs
@@ -4,6 +4,7 @@ module Rules.Generate (
     ghcPrimDependencies
     ) where
 
+import qualified Data.Set as Set
 import Base
 import qualified Context
 import Expression
@@ -340,7 +341,7 @@ generateSettings = do
 
         , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter)
         , ("Support SMP", expr $ yesNo <$> targetSupportsSMP)
-        , ("RTS ways", unwords . map show <$> getRtsWays)
+        , ("RTS ways", unwords . map show . Set.toList <$> getRtsWays)
         , ("Tables next to code", expr $ yesNo <$> flag TablesNextToCode)
         , ("Leading underscore", expr $ yesNo <$> flag LeadingUnderscore)
         , ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
index 683f308bfc..ad91e941cb 100644
--- a/hadrian/src/Rules/Program.hs
+++ b/hadrian/src/Rules/Program.hs
@@ -1,5 +1,7 @@
 module Rules.Program (buildProgramRules) where
 
+import qualified Data.Set as Set
+
 import Hadrian.Haskell.Cabal
 import Hadrian.Haskell.Cabal.Type
 
@@ -113,7 +115,7 @@ buildBinary rs bin context@Context {..} = do
     needLibrary =<< contextDependencies context
     when (stage > Stage0) $ do
         ways <- interpretInContext context (getLibraryWays <> getRtsWays)
-        needLibrary [ (rtsContext stage) { way = w } | w <- ways ]
+        needLibrary [ (rtsContext stage) { way = w } | w <- Set.toList ways ]
     asmSrcs <- interpretInContext context (getContextData asmSrcs)
     asmObjs <- mapM (objectPath context) asmSrcs
     cSrcs   <- interpretInContext context (getContextData cSrcs)
diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs
index c510e96c02..8527864f77 100644
--- a/hadrian/src/Rules/Register.hs
+++ b/hadrian/src/Rules/Register.hs
@@ -19,6 +19,7 @@ import Utilities
 
 import Hadrian.Haskell.Cabal.Type
 import qualified Text.Parsec      as Parsec
+import qualified Data.Set         as Set
 
 import Distribution.Version (Version)
 import qualified Distribution.Parsec as Cabal
@@ -122,7 +123,7 @@ buildConf _ context@Context {..} _conf = do
     need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) depPkgIds
 
     ways <- interpretInContext context (getLibraryWays <> if package == rts then getRtsWays else mempty)
-    need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- ways ]
+    need =<< concatMapM (libraryTargets True) [ context { way = w } | w <- Set.toList ways ]
 
     -- We might need some package-db resource to limit read/write, see packageRules.
     path <- buildPath context
diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs
index 4e6b4f7532..a6cd0f15d2 100644
--- a/hadrian/src/Rules/Rts.hs
+++ b/hadrian/src/Rules/Rts.hs
@@ -1,5 +1,7 @@
 module Rules.Rts (rtsRules, needRtsLibffiTargets, needRtsSymLinks) where
 
+import qualified Data.Set as Set
+
 import Packages (rts, rtsBuildPath, libffiBuildPath, rtsContext)
 import Rules.Libffi
 import Hadrian.Utilities
@@ -136,15 +138,15 @@ needRtsLibffiTargets stage = do
         staticLibffis <- do
             ways <- interpretInContext (stageContext stage)
                                        (getLibraryWays <> getRtsWays)
-            let staticWays = filter (not . wayUnit Dynamic) ways
+            let staticWays = Set.toList $ Set.filter (not . wayUnit Dynamic) ways
             mapM (rtsLibffiLibrary stage) staticWays
 
         return $ concat [ headers, dynLibffis, staticLibffis ]
 
 -- Need symlinks generated by rtsRules.
-needRtsSymLinks :: Stage -> [Way] -> Action ()
+needRtsSymLinks :: Stage -> Set.Set Way -> Action ()
 needRtsSymLinks stage rtsWays
-    = forM_ (filter (wayUnit Dynamic) rtsWays) $ \ way -> do
+    = forM_ (Set.filter (wayUnit Dynamic) rtsWays) $ \ way -> do
         let ctx = Context stage rts way
         libPath     <- libPath ctx
         distDir     <- distDir stage
diff --git a/hadrian/src/Settings/Builders/Cabal.hs b/hadrian/src/Settings/Builders/Cabal.hs
index c6a83ce12b..82e34d8594 100644
--- a/hadrian/src/Settings/Builders/Cabal.hs
+++ b/hadrian/src/Settings/Builders/Cabal.hs
@@ -10,6 +10,7 @@ import Packages
 import Settings.Builders.Common
 import qualified Settings.Builders.Common as S
 import Control.Exception (assert)
+import qualified Data.Set as Set
 import System.Directory
 import Settings.Program (programContext)
 
@@ -140,7 +141,7 @@ libraryArgs = do
     withGhci    <- expr ghcWithInterpreter
     dynPrograms <- expr (flavour >>= dynamicGhcPrograms)
     ghciObjsSupported <- expr platformSupportsGhciObjects
-    let ways = flavourWays ++ [contextWay]
+    let ways = Set.insert contextWay flavourWays
         hasVanilla = vanilla `elem` ways
         hasProfiling = any (wayUnit Profiling) ways
         hasDynamic = any (wayUnit Dynamic) ways
diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs
index a22e0079a7..6c47c2fba1 100644
--- a/hadrian/src/Settings/Builders/Ghc.hs
+++ b/hadrian/src/Settings/Builders/Ghc.hs
@@ -11,6 +11,7 @@ import Settings.Builders.Common
 import Settings.Warnings
 import qualified Context as Context
 import Rules.Libffi (libffiName)
+import qualified Data.Set as Set
 import System.Directory
 
 ghcBuilderArgs :: Args
@@ -188,7 +189,7 @@ findHsDependencies = builder (Ghc FindHsDependencies) ? do
             , defaultGhcWarningsArgs
             , arg "-include-pkg-deps"
             , arg "-dep-makefile", arg =<< getOutput
-            , pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- ways ]
+            , pure $ concat [ ["-dep-suffix", wayPrefix w] | w <- Set.toList ways ]
             , getInputs ]
 
 haddockGhcArgs :: Args
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index 2360a2205d..611cf54c6a 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -57,8 +57,8 @@ runTestGhcFlags = do
 
 data TestCompilerArgs = TestCompilerArgs{
     hasDynamicRts, hasThreadedRts :: Bool
- ,   libWays :: [Way]
- ,   hasDynamic :: Bool
+ ,   libWays           :: Set.Set Way
+ ,   hasDynamic        :: Bool
  ,   leadingUnderscore :: Bool
  ,   withNativeCodeGen :: Bool
  ,   withInterpreter   :: Bool
@@ -382,14 +382,14 @@ setTestSpeed TestFast   = "2"
 --   - if we find @PrimopWrappers.hi@, we have the vanilla way;
 --   - if we find @PrimopWrappers.dyn_hi@, we have the dynamic way;
 --   - if we find @PrimopWrappers.p_hi@, we have the profiling way.
-inferLibraryWays :: String -> Action [Way]
+inferLibraryWays :: String -> Action (Set.Set Way)
 inferLibraryWays compiler = do
   bindir <- getBinaryDirectory compiler
   Stdout ghcPrimLibdirDirty <- cmd
     [bindir </> "ghc-pkg" <.> exe]
     ["field", "ghc-prim", "library-dirs", "--simple-output"]
   let ghcPrimLibdir = fixup ghcPrimLibdirDirty
-  ways <- catMaybes <$> traverse (lookForWay ghcPrimLibdir) candidateWays
+  ways <- Set.fromList . catMaybes <$> traverse (lookForWay ghcPrimLibdir) candidateWays
   return ways
 
   where lookForWay dir (hifile, w) = do
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 81e27ed785..5e2c5f54f7 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -13,6 +13,8 @@ module Settings.Default (
     defaultFlavour, defaultBignumBackend
     ) where
 
+import qualified Data.Set as Set
+
 import qualified Hadrian.Builder.Sphinx
 import qualified Hadrian.Builder.Tar
 import Hadrian.Haskell.Cabal.Type
@@ -162,7 +164,8 @@ testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact,
 -- * We build 'profiling' way when stage > Stage0.
 -- * We build 'dynamic' way when stage > Stage0 and the platform supports it.
 defaultLibraryWays :: Ways
-defaultLibraryWays = mconcat
+defaultLibraryWays = Set.fromList <$>
+    mconcat
     [ pure [vanilla]
     , notStage0 ? pure [profiling]
     , notStage0 ? platformSupportsSharedLibs ? pure [dynamic]
@@ -170,7 +173,8 @@ defaultLibraryWays = mconcat
 
 -- | Default build ways for the RTS.
 defaultRtsWays :: Ways
-defaultRtsWays = mconcat
+defaultRtsWays = Set.fromList <$>
+  mconcat
   [ pure [vanilla, threaded]
   , notStage0 ? pure
       [ profiling, threadedProfiling, debugProfiling, threadedDebugProfiling
diff --git a/hadrian/src/Settings/Flavours/Benchmark.hs b/hadrian/src/Settings/Flavours/Benchmark.hs
index f0dcd7bead..e4c5de0199 100644
--- a/hadrian/src/Settings/Flavours/Benchmark.hs
+++ b/hadrian/src/Settings/Flavours/Benchmark.hs
@@ -1,5 +1,6 @@
 module Settings.Flavours.Benchmark (benchmarkFlavour) where
 
+import qualified Data.Set as Set
 import Expression
 import Flavour
 import {-# SOURCE #-} Settings.Default
@@ -9,8 +10,8 @@ benchmarkFlavour :: Flavour
 benchmarkFlavour = defaultFlavour
     { name = "bench"
     , args = defaultBuilderArgs <> benchmarkArgs <> defaultPackageArgs
-    , libraryWays = pure [vanilla]
-    , rtsWays = pure [vanilla, threaded, logging, threadedLogging] }
+    , libraryWays = pure $ Set.fromList [vanilla]
+    , rtsWays = pure $ Set.fromList [vanilla, threaded, logging, threadedLogging] }
 
 benchmarkArgs :: Args
 benchmarkArgs = sourceArgs SourceArgs
diff --git a/hadrian/src/Settings/Flavours/Development.hs b/hadrian/src/Settings/Flavours/Development.hs
index 9c0a342bac..94a008fc47 100644
--- a/hadrian/src/Settings/Flavours/Development.hs
+++ b/hadrian/src/Settings/Flavours/Development.hs
@@ -1,5 +1,7 @@
 module Settings.Flavours.Development (developmentFlavour) where
 
+import qualified Data.Set as Set
+
 import Expression
 import Flavour
 import Packages
@@ -10,8 +12,8 @@ developmentFlavour :: Stage -> Flavour
 developmentFlavour ghcStage = defaultFlavour
     { name = "devel" ++ show (fromEnum ghcStage)
     , args = defaultBuilderArgs <> developmentArgs ghcStage <> defaultPackageArgs
-    , libraryWays = pure [vanilla]
-    , rtsWays = pure [vanilla, logging, debug, threaded, threadedLogging, threadedDebug]
+    , libraryWays = pure $ Set.fromList [vanilla]
+    , rtsWays = pure $ Set.fromList [vanilla, logging, debug, threaded, threadedLogging, threadedDebug]
     , dynamicGhcPrograms = return False
     , ghcDebugAssertions = True }
 
diff --git a/hadrian/src/Settings/Flavours/GhcInGhci.hs b/hadrian/src/Settings/Flavours/GhcInGhci.hs
index 950b96f926..b0859ffc56 100644
--- a/hadrian/src/Settings/Flavours/GhcInGhci.hs
+++ b/hadrian/src/Settings/Flavours/GhcInGhci.hs
@@ -1,5 +1,7 @@
 module Settings.Flavours.GhcInGhci (ghcInGhciFlavour) where
 
+import qualified Data.Set as Set
+
 import Expression
 import Flavour
 import {-# SOURCE #-} Settings.Default
@@ -12,8 +14,8 @@ ghcInGhciFlavour = defaultFlavour
     -- We can't build DLLs on Windows (yet). Actually we should only
     -- include the dynamic way when we have a dynamic host GHC, but just
     -- checking for Windows seems simpler for now.
-    , libraryWays = pure [vanilla] <> pure [ dynamic | not windowsHost ]
-    , rtsWays     = pure [vanilla, threaded] <> pure [ dynamic | not windowsHost ]
+    , libraryWays = pure (Set.fromList [vanilla]) <> pure (Set.fromList [ dynamic | not windowsHost ])
+    , rtsWays     = pure (Set.fromList [vanilla, threaded]) <> pure (Set.fromList [ dynamic | not windowsHost ])
     , dynamicGhcPrograms = return False }
 
 ghciArgs :: Args
diff --git a/hadrian/src/Settings/Flavours/Quick.hs b/hadrian/src/Settings/Flavours/Quick.hs
index c8ac089335..2ddf45b1a1 100644
--- a/hadrian/src/Settings/Flavours/Quick.hs
+++ b/hadrian/src/Settings/Flavours/Quick.hs
@@ -4,6 +4,8 @@ module Settings.Flavours.Quick
    )
 where
 
+import qualified Data.Set as Set
+
 import Expression
 import Flavour
 import Oracles.Flag
@@ -14,10 +16,12 @@ quickFlavour :: Flavour
 quickFlavour = defaultFlavour
     { name        = "quick"
     , args        = defaultBuilderArgs <> quickArgs <> defaultPackageArgs
-    , libraryWays = mconcat
+    , libraryWays = Set.fromList <$>
+                    mconcat
                     [ pure [vanilla]
                     , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ]
-    , rtsWays     = mconcat
+    , rtsWays     = Set.fromList <$>
+                    mconcat
                     [ pure
                       [ vanilla, threaded, logging, debug
                       , threadedDebug, threadedLogging, threaded ]
diff --git a/hadrian/src/Settings/Flavours/QuickCross.hs b/hadrian/src/Settings/Flavours/QuickCross.hs
index 5e9dc05f08..35b0dcc988 100644
--- a/hadrian/src/Settings/Flavours/QuickCross.hs
+++ b/hadrian/src/Settings/Flavours/QuickCross.hs
@@ -1,5 +1,7 @@
 module Settings.Flavours.QuickCross (quickCrossFlavour) where
 
+import qualified Data.Set as Set
+
 import Expression
 import Flavour
 import Oracles.Flag
@@ -11,10 +13,12 @@ quickCrossFlavour = defaultFlavour
     { name        = "quick-cross"
     , args        = defaultBuilderArgs <> quickCrossArgs <> defaultPackageArgs
     , dynamicGhcPrograms = pure False
-    , libraryWays = mconcat
+    , libraryWays = Set.fromList <$>
+                    mconcat
                     [ pure [vanilla]
                     , notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ]
-    , rtsWays     = mconcat
+    , rtsWays     = Set.fromList <$>
+                    mconcat
                     [ pure
                       [ vanilla, threaded, logging, debug
                       , threadedDebug, threadedLogging, threaded ]
diff --git a/hadrian/src/Settings/Flavours/Quickest.hs b/hadrian/src/Settings/Flavours/Quickest.hs
index c0c7c9c446..6ab1ed3068 100644
--- a/hadrian/src/Settings/Flavours/Quickest.hs
+++ b/hadrian/src/Settings/Flavours/Quickest.hs
@@ -1,5 +1,7 @@
 module Settings.Flavours.Quickest (quickestFlavour) where
 
+import qualified Data.Set as Set
+
 import Expression
 import Flavour
 import {-# SOURCE #-} Settings.Default
@@ -9,8 +11,8 @@ quickestFlavour :: Flavour
 quickestFlavour = defaultFlavour
     { name        = "quickest"
     , args        = defaultBuilderArgs <> quickestArgs <> defaultPackageArgs
-    , libraryWays = pure [vanilla]
-    , rtsWays     = pure [vanilla, threaded, threadedLogging, logging]
+    , libraryWays = pure (Set.fromList [vanilla])
+    , rtsWays     = pure (Set.fromList [vanilla, threaded, threadedLogging, logging])
     , dynamicGhcPrograms = return False }
 
 quickestArgs :: Args
diff --git a/hadrian/src/Settings/Flavours/Validate.hs b/hadrian/src/Settings/Flavours/Validate.hs
index 7e54278f90..913e431b58 100644
--- a/hadrian/src/Settings/Flavours/Validate.hs
+++ b/hadrian/src/Settings/Flavours/Validate.hs
@@ -1,6 +1,8 @@
 module Settings.Flavours.Validate (validateFlavour, slowValidateFlavour,
                                     quickValidateFlavour) where
 
+import qualified Data.Set as Set
+
 import Expression
 import Flavour
 import Oracles.Flag
@@ -11,10 +13,12 @@ validateFlavour :: Flavour
 validateFlavour = werror $ defaultFlavour
     { name = "validate"
     , args = defaultBuilderArgs <> validateArgs <> defaultPackageArgs
-    , libraryWays = mconcat [ pure [vanilla]
+    , libraryWays = Set.fromList <$>
+                    mconcat [ pure [vanilla]
                             , notStage0 ? platformSupportsSharedLibs ? pure [dynamic]
                             ]
-    , rtsWays = mconcat [ pure [vanilla, threaded, debug, logging, threadedDebug, threadedLogging]
+    , rtsWays = Set.fromList <$>
+                mconcat [ pure [vanilla, threaded, debug, logging, threadedDebug, threadedLogging]
                         , notStage0 ? platformSupportsSharedLibs ? pure
                             [ dynamic, threadedDynamic, debugDynamic, threadedDebugDynamic
                             , loggingDynamic, threadedLoggingDynamic