Skip to content

GitLab

GHC
GHC
Commit 494eb3dc authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files
Options

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.
parent db5c6adc
Hide whitespace changes
Inline Side-by-side
Showing with 118 additions and 117 deletions
compiler/main/DriverPipeline.hs
View file @ 494eb3dc
......@@ -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
View file @ 494eb3dc
......@@ -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
View file @ 494eb3dc
......@@ -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
View file @ 494eb3dc
......@@ -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
View file @ 494eb3dc
......@@ -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
View file @ 494eb3dc
......@@ -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.")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment