Refactor the ways code a bit

We used to use a list lookup that couldn't fail. Now we just use
functions.

There were 3 overlapping entries for WayPar; I've commented out the ones
that were shadowed for now.

compiler/main/DriverPipeline.hs

@@ -39,7 +39,7 @@ import Module
 import UniqFM           ( eltsUFM )
 import ErrUtils
 import DynFlags
-import StaticFlags      ( v_Ld_inputs, opt_Static, WayName(..) )
+import StaticFlags      ( v_Ld_inputs, opt_Static, Way(..) )
 import Config
 import Panic
 import Util
@@ -1448,9 +1448,9 @@ maybeMergeStub
 
 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
 runPhase_MoveBinary dflags input_fn
-    | WayPar `elem` (wayNames dflags) && not opt_Static =
+    | WayPar `elem` ways dflags && not opt_Static =
         panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
-    | WayPar `elem` (wayNames dflags) = do
+    | WayPar `elem` ways dflags = do
         let sysMan = pgm_sysman dflags
         pvm_root <- getEnv "PVM_ROOT"
         pvm_arch <- getEnv "PVM_ARCH"
@@ -1720,13 +1720,11 @@ linkBinary dflags o_files dep_packages = do
         -- opts from -optl-<blah> (including -l<blah> options)
     let extra_ld_opts = getOpts dflags opt_l
 
-    let ways = wayNames dflags
-
     -- Here are some libs that need to be linked at the *end* of
     -- the command line, because they contain symbols that are referred to
     -- by the RTS.  We can't therefore use the ordinary way opts for these.
     let
-        debug_opts | WayDebug `elem` ways = [
+        debug_opts | WayDebug `elem` ways dflags = [
 #if defined(HAVE_LIBBFD)
                         "-lbfd", "-liberty"
 #endif
@@ -1734,7 +1732,7 @@ linkBinary dflags o_files dep_packages = do
                    | otherwise            = []
 
     let
-        thread_opts | WayThreaded `elem` ways = [
+        thread_opts | WayThreaded `elem` ways dflags = [
 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(netbsd_TARGET_OS) && !defined(haiku_TARGET_OS)
                         "-lpthread"
 #endif

compiler/main/DynFlags.hs

@@ -45,7 +45,7 @@ module DynFlags (
         Option(..), showOpt,
         DynLibLoader(..),
         fFlags, fWarningFlags, fLangFlags, xFlags,
-        wayNames, dynFlagDependencies,
+        dynFlagDependencies,
         tablesNextToCode, mkTablesNextToCode,
 
         printOutputForUser, printInfoForUser,
@@ -765,9 +765,6 @@ opt_lo dflags = sOpt_lo (settings dflags)
 opt_lc                :: DynFlags -> [String]
 opt_lc dflags = sOpt_lc (settings dflags)
 
-wayNames :: DynFlags -> [WayName]
-wayNames = map wayName . ways
-
 -- | The target code type of the compilation (if any).
 --
 -- Whenever you change the target, also make sure to set 'ghcLink' to
@@ -1420,7 +1417,7 @@ getStgToDo dflags
 
         todo1 = if stg_stats then [D_stg_stats] else []
 
-        todo2 | WayProf `elem` wayNames dflags
+        todo2 | WayProf `elem` ways dflags
               = StgDoMassageForProfiling : todo1
               | otherwise
               = todo1

compiler/main/Packages.lhs

@@ -883,13 +883,13 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
   where
         ways0 = ways dflags
 
-        ways1 = filter ((/= WayDyn) . wayName) ways0
+        ways1 = filter (/= WayDyn) ways0
         -- the name of a shared library is libHSfoo-ghc<version>.so
         -- we leave out the _dyn, because it is superfluous
 
         -- debug RTS includes support for -eventlog
-        ways2 | WayDebug `elem` map wayName ways1
-              = filter ((/= WayEventLog) . wayName) ways1
+        ways2 | WayDebug `elem` ways1
+              = filter (/= WayEventLog) ways1
               | otherwise
               = ways1
 

compiler/main/StaticFlagParser.hs

@@ -18,7 +18,7 @@ module StaticFlagParser (
 #include "HsVersions.h"
 
 import qualified StaticFlags as SF
-import StaticFlags ( v_opt_C_ready, getWayFlags, WayName(..)
+import StaticFlags ( v_opt_C_ready, getWayFlags, Way(..)
                    , opt_SimplExcessPrecision )
 import CmdLineParser
 import SrcLoc
@@ -203,7 +203,7 @@ type StaticP = EwM IO
 addOpt :: String -> StaticP ()
 addOpt = liftEwM . SF.addOpt
 
-addWay :: WayName -> StaticP ()
+addWay :: Way -> StaticP ()
 addWay = liftEwM . SF.addWay
 
 removeOpt :: String -> StaticP ()

compiler/main/StaticFlags.hs

@@ -24,7 +24,7 @@ module StaticFlags (
         initStaticOpts,
 
 	-- Ways
-	WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag,
+	Way(..), v_Ways, mkBuildTag, wayRTSOnly,
 
 	-- Output style options
 	opt_PprStyle_Debug,
@@ -91,8 +91,6 @@ import Maybes		( firstJusts )
 import Panic
 
 import Control.Monad    ( liftM3 )
-import Data.Function
-import Data.Maybe       ( listToMaybe )
 import Data.IORef
 import System.IO.Unsafe	( unsafePerformIO )
 import Data.List
@@ -106,8 +104,8 @@ initStaticOpts = writeIORef v_opt_C_ready True
 addOpt :: String -> IO ()
 addOpt = consIORef v_opt_C
 
-addWay :: WayName -> IO ()
-addWay = consIORef v_Ways . lkupWay
+addWay :: Way -> IO ()
+addWay = consIORef v_Ways
 
 removeOpt :: String -> IO ()
 removeOpt f = do
@@ -337,7 +335,7 @@ GLOBAL_VAR(v_Ld_inputs,	[],      [String])
 -- becomes the suffix used to find .hi files and libraries used in
 -- this compilation.
 
-data WayName
+data Way
   = WayThreaded
   | WayDebug
   | WayProf
@@ -350,7 +348,7 @@ data WayName
 
 GLOBAL_VAR(v_Ways, [] ,[Way])
 
-allowed_combination :: [WayName] -> Bool
+allowed_combination :: [Way] -> Bool
 allowed_combination way = and [ x `allowedWith` y
 			      | x <- way, y <- way, x < y ]
   where
@@ -375,11 +373,10 @@ allowed_combination way = and [ x `allowedWith` y
 getWayFlags :: IO [String]  -- new options
 getWayFlags = do
   unsorted <- readIORef v_Ways
-  let ways = sortBy (compare `on` wayName) $
-             nubBy  ((==) `on` wayName) $ unsorted
+  let ways = sort $ nub $ unsorted
   writeIORef v_Ways ways
 
-  if not (allowed_combination (map wayName ways))
+  if not (allowed_combination ways)
       then ghcError (CmdLineError $
       		    "combination not supported: "  ++
       		    foldr1 (\a b -> a ++ '/':b)
@@ -390,112 +387,121 @@ getWayFlags = do
 mkBuildTag :: [Way] -> String
 mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
 
-lkupWay :: WayName -> Way
-lkupWay w =
-   case listToMaybe (filter ((==) w . wayName) way_details) of
-	Nothing -> error "findBuildTag"
-	Just details -> details
-
-isRTSWay :: WayName -> Bool
-isRTSWay = wayRTSOnly . lkupWay
-
-data Way = Way {
-  wayName    :: WayName,
-  wayTag     :: String,
-  wayRTSOnly :: Bool,
-  wayDesc    :: String,
-  wayOpts    :: [String]
-  }
-
-way_details :: [ Way ]
-way_details =
-  [ Way WayThreaded "thr" True "Threaded" [
+wayTag :: Way -> String
+wayTag WayThreaded = "thr"
+wayTag WayDebug    = "debug"
+wayTag WayDyn      = "dyn"
+wayTag WayProf     = "p"
+wayTag WayEventLog = "l"
+wayTag WayPar      = "mp"
+-- wayTag WayPar      = "mt"
+-- wayTag WayPar      = "md"
+wayTag WayGran     = "mg"
+wayTag WayNDP      = "ndp"
+
+wayRTSOnly :: Way -> Bool
+wayRTSOnly WayThreaded = True
+wayRTSOnly WayDebug    = True
+wayRTSOnly WayDyn      = False
+wayRTSOnly WayProf     = False
+wayRTSOnly WayEventLog = True
+wayRTSOnly WayPar      = False
+-- wayRTSOnly WayPar      = False
+-- wayRTSOnly WayPar      = False
+wayRTSOnly WayGran     = False
+wayRTSOnly WayNDP      = False
+
+wayDesc :: Way -> String
+wayDesc WayThreaded = "Threaded"
+wayDesc WayDebug    = "Debug"
+wayDesc WayDyn      = "Dynamic"
+wayDesc WayProf     = "Profiling"
+wayDesc WayEventLog = "RTS Event Logging"
+wayDesc WayPar      = "Parallel"
+-- wayDesc WayPar      = "Parallel ticky profiling"
+-- wayDesc WayPar      = "Distributed"
+wayDesc WayGran     = "GranSim"
+wayDesc WayNDP      = "Nested data parallelism"
+
+wayOpts :: Way -> [String]
+wayOpts WayThreaded = [
 #if defined(freebsd_TARGET_OS)
---	  "-optc-pthread"
+--        "-optc-pthread"
 --      , "-optl-pthread"
-	-- FreeBSD's default threading library is the KSE-based M:N libpthread,
-	-- which GHC has some problems with.  It's currently not clear whether
-	-- the problems are our fault or theirs, but it seems that using the
-	-- alternative 1:1 threading library libthr works around it:
-	  "-optl-lthr"
+        -- FreeBSD's default threading library is the KSE-based M:N libpthread,
+        -- which GHC has some problems with.  It's currently not clear whether
+        -- the problems are our fault or theirs, but it seems that using the
+        -- alternative 1:1 threading library libthr works around it:
+          "-optl-lthr"
 #elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS)
-	  "-optc-pthread"
-	, "-optl-pthread"
+          "-optc-pthread"
+        , "-optl-pthread"
 #elif defined(solaris2_TARGET_OS)
           "-optl-lrt"
 #endif
-	],
-
-    Way WayDebug "debug" True "Debug" [],
-
-    Way WayDyn "dyn" False "Dynamic"
-	[ "-DDYNAMIC"
-	, "-optc-DDYNAMIC"
+        ]
+wayOpts WayDebug = []
+wayOpts WayDyn =
+        [ "-DDYNAMIC"
+        , "-optc-DDYNAMIC"
 #if defined(mingw32_TARGET_OS)
-	-- On Windows, code that is to be linked into a dynamic library must be compiled
-	--	with -fPIC. Labels not in the current package are assumed to be in a DLL
-	--	different from the current one.
-	, "-fPIC"
+        -- On Windows, code that is to be linked into a dynamic library must be compiled
+        --      with -fPIC. Labels not in the current package are assumed to be in a DLL
+        --      different from the current one.
+        , "-fPIC"
 #elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS)
-	-- Without this, linking the shared libHSffi fails because
-	-- it uses pthread mutexes.
-	, "-optl-pthread"
+        -- Without this, linking the shared libHSffi fails because
+        -- it uses pthread mutexes.
+        , "-optl-pthread"
 #endif
-	],
-
-    Way WayProf "p" False "Profiling"
-	[ "-fscc-profiling"
-	, "-DPROFILING"
-	, "-optc-DPROFILING" ],
-
-    Way WayEventLog "l" True "RTS Event Logging"
-	[ "-DTRACING"
-	, "-optc-DTRACING" ],
-
-    Way WayPar "mp" False "Parallel"
-	[ "-fparallel"
-	, "-D__PARALLEL_HASKELL__"
-	, "-optc-DPAR"
-	, "-package concurrent"
+        ]
+wayOpts WayProf =
+        [ "-fscc-profiling"
+        , "-DPROFILING"
+        , "-optc-DPROFILING" ]
+wayOpts WayEventLog =
+        [ "-DTRACING"
+        , "-optc-DTRACING" ]
+wayOpts WayPar =
+        [ "-fparallel"
+        , "-D__PARALLEL_HASKELL__"
+        , "-optc-DPAR"
+        , "-package concurrent"
         , "-optc-w"
         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
         , "-optl-lpvm3"
-        , "-optl-lgpvm3" ],
-
-    -- at the moment we only change the RTS and could share compiler and libs!
-    Way WayPar "mt" False "Parallel ticky profiling"
-	[ "-fparallel"
-	, "-D__PARALLEL_HASKELL__"
-	, "-optc-DPAR"
-	, "-optc-DPAR_TICKY"
-	, "-package concurrent"
+        , "-optl-lgpvm3" ]
+{-
+wayOpts WayPar =
+        [ "-fparallel"
+        , "-D__PARALLEL_HASKELL__"
+        , "-optc-DPAR"
+        , "-optc-DPAR_TICKY"
+        , "-package concurrent"
         , "-optc-w"
         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
         , "-optl-lpvm3"
-        , "-optl-lgpvm3" ],
-
-    Way WayPar "md" False "Distributed"
-	[ "-fparallel"
-	, "-D__PARALLEL_HASKELL__"
-	, "-D__DISTRIBUTED_HASKELL__"
-	, "-optc-DPAR"
-	, "-optc-DDIST"
-	, "-package concurrent"
+        , "-optl-lgpvm3" ]
+wayOpts WayPar =
+        [ "-fparallel"
+        , "-D__PARALLEL_HASKELL__"
+        , "-D__DISTRIBUTED_HASKELL__"
+        , "-optc-DPAR"
+        , "-optc-DDIST"
+        , "-package concurrent"
         , "-optc-w"
         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
         , "-optl-lpvm3"
-        , "-optl-lgpvm3" ],
-
-    Way WayGran "mg" False "GranSim"
-	[ "-fgransim"
-	, "-D__GRANSIM__"
-	, "-optc-DGRAN"
-	, "-package concurrent" ],
-
-    Way WayNDP "ndp" False "Nested data parallelism"
-	[ "-XParr"
-	, "-fvectorise"]
-  ]
+        , "-optl-lgpvm3" ]
+-}
+wayOpts WayGran =
+        [ "-fgransim"
+        , "-D__GRANSIM__"
+        , "-optc-DGRAN"
+        , "-package concurrent" ]
+wayOpts WayNDP =
+        [ "-XParr"
+        , "-fvectorise"]
 
 -----------------------------------------------------------------------------
 -- Tunneling our global variables into a new instance of the GHC library

ghc/Main.hs

@@ -289,12 +289,12 @@ checkOptions mode dflags srcs objs = do
    let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
    when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
 
-   when (notNull (filter isRTSWay (wayNames dflags))
+   when (notNull (filter wayRTSOnly (ways dflags))
          && isInterpretiveMode mode) $
         hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
 
         -- -prof and --interactive are not a good combination
-   when (notNull (filter (not . isRTSWay) (wayNames dflags))
+   when (notNull (filter (not . wayRTSOnly) (ways dflags))
          && isInterpretiveMode mode) $
       do ghcError (UsageError
                    "--interactive can't be used with -prof or -unreg.")