diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 12 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 7 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 6 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 4 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 202 | ||||
| -rw-r--r-- | ghc/Main.hs | 4 |
6 files changed, 118 insertions, 117 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index fe158460cb..6eff097bfb 100644 --- a/compiler/main/DriverPipeline.hs +++ b/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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index f2a7daae42..b227172264 100644 --- a/compiler/main/DynFlags.hs +++ b/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 diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 5bea131088..0f9ab3647b 100644 --- a/compiler/main/Packages.lhs +++ b/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 diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 2b7f95a910..8f6ff84ec8 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/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 () diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 2334940492..ec5be5fa3b 100644 --- a/compiler/main/StaticFlags.hs +++ b/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 diff --git a/ghc/Main.hs b/ghc/Main.hs index 5eda655333..53ca70e296 100644 --- a/ghc/Main.hs +++ b/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.") |