diff options
| -rw-r--r-- | compiler/ghci/Linker.lhs | 2 | ||||
| -rw-r--r-- | compiler/iface/BinIface.hs | 20 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 22 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 10 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 4 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 132 |
6 files changed, 78 insertions, 112 deletions
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 5c05122ed4..419cb4f968 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -526,7 +526,7 @@ dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String) checkNonStdWay dflags srcspan = do - tag <- readIORef v_Build_tag + let tag = buildTag dflags if null tag then return Nothing else do let default_osuf = phaseInputExt StopLn if objectSuf dflags == default_osuf diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 26613267c1..f09ce4f7d2 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -58,12 +58,13 @@ readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> TcRnIf a b ModIface readBinIface checkHiWay traceBinIFaceReading hi_path = do update_nc <- mkNameCacheUpdater - liftIO $ readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc + dflags <- getDOpts + liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc -readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath +readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCacheUpdater (Array Int Name) -> IO ModIface -readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc = do +readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do let printer :: SDoc -> IO () printer = case traceBinIFaceReading of TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle @@ -105,7 +106,7 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path update_nc = do errorOnMismatch "mismatched interface file versions" our_ver check_ver check_way <- get bh - way_descr <- getWayDescr + let way_descr = getWayDescr dflags wantedGot "Way" way_descr check_way when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file ways" way_descr check_way @@ -144,7 +145,7 @@ writeBinIface dflags hi_path mod_iface = do -- The version and way descriptor go next put_ bh (show opt_HiVersion) - way_descr <- getWayDescr + let way_descr = getWayDescr dflags put_ bh way_descr -- Remember where the symbol table pointer will go @@ -448,10 +449,11 @@ instance Binary ModIface where mi_fix_fn = mkIfaceFixCache fixities, mi_hash_fn = mkIfaceHashCache decls }) -getWayDescr :: IO String -getWayDescr = do - tag <- readIORef v_Build_tag - if cGhcUnregisterised == "YES" then return ('u':tag) else return tag +getWayDescr :: DynFlags -> String +getWayDescr dflags + | cGhcUnregisterised == "YES" = 'u':tag + | otherwise = tag + where tag = buildTag dflags -- if this is an unregisterised build, make sure our interfaces -- can't be used by a registerised build. diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a1ae15f8a8..b0d43002e0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -21,6 +21,7 @@ module DynFlags ( DynLibLoader(..), fFlags, xFlags, dphPackage, + wayNames, -- ** Manipulating DynFlags defaultDynFlags, -- DynFlags @@ -69,11 +70,7 @@ import Platform import Module import PackageConfig import PrelNames ( mAIN ) -#if defined(i386_TARGET_ARCH) || (!defined(mingw32_TARGET_OS) && !defined(darwin_TARGET_OS)) -import StaticFlags ( opt_Static ) -#endif -import StaticFlags ( opt_PIC, WayName(..), v_Ways, v_Build_tag, - v_RTS_Build_tag ) +import StaticFlags import {-# SOURCE #-} Packages (PackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config @@ -371,7 +368,7 @@ data DynFlags = DynFlags { thisPackage :: PackageId, -- ^ name of package currently being compiled -- ways - wayNames :: [WayName], -- ^ Way flags from the command line + ways :: [Way], -- ^ Way flags from the command line buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) rtsBuildTag :: String, -- ^ The RTS \"way\" @@ -471,6 +468,9 @@ data DynFlags = DynFlags { haddockOptions :: Maybe String } +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 @@ -571,14 +571,12 @@ initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do -- someday these will be dynamic flags ways <- readIORef v_Ways - build_tag <- readIORef v_Build_tag - rts_build_tag <- readIORef v_RTS_Build_tag refFilesToClean <- newIORef [] refDirsToClean <- newIORef emptyFM return dflags{ - wayNames = ways, - buildTag = build_tag, - rtsBuildTag = rts_build_tag, + ways = ways, + buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), + rtsBuildTag = mkBuildTag ways, filesToClean = refFilesToClean, dirsToClean = refDirsToClean } @@ -654,7 +652,7 @@ defaultDynFlags = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", - wayNames = panic "defaultDynFlags: No wayNames", + ways = panic "defaultDynFlags: No ways", buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index bdb8cf724a..7cb3337267 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -38,7 +38,7 @@ where import PackageConfig import ParsePkgConf ( loadPackageConfig ) import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) -import StaticFlags ( opt_Static ) +import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM @@ -644,8 +644,12 @@ collectLinkOpts dflags ps = concat (map all_opts ps) packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) where - tag = buildTag dflags - rts_tag = rtsBuildTag dflags + non_dyn_ways = filter ((/= WayDyn) . wayName) (ways dflags) + -- 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 mkDynName | opt_Static = id | otherwise = (++ ("-ghc" ++ cProjectVersion)) diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index f3d737cbd7..a153435967 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -53,7 +53,7 @@ parseStaticFlags args = do -- deal with the way flags: the way (eg. prof) gives rise to -- further flags, some of which might be static. - way_flags <- findBuildTag + way_flags <- getWayFlags let way_flags' = map (mkGeneralLocated "in way flags") way_flags -- if we're unregisterised, add some more flags @@ -128,7 +128,7 @@ static_flags = [ ----- Linker -------------------------------------------------------- , Flag "static" (PassFlag addOpt) Supported - , Flag "dynamic" (NoArg (removeOpt "-static")) Supported + , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) Supported -- ignored for compat w/ gcc: , Flag "rdynamic" (NoArg (return ())) Supported diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index b13661ed99..ffa15841ad 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -17,7 +17,7 @@ module StaticFlags ( initStaticOpts, -- Ways - WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag, isRTSWay, + WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag, -- Output style options opt_PprUserLength, @@ -73,7 +73,7 @@ module StaticFlags ( opt_StubDeadValues, -- For the parser - addOpt, removeOpt, addWay, findBuildTag, v_opt_C_ready + addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready ) where #include "HsVersions.h" @@ -84,6 +84,7 @@ import Util import Maybes ( firstJust ) import Panic +import Data.Maybe ( listToMaybe ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Data.List @@ -98,7 +99,7 @@ addOpt :: String -> IO () addOpt = consIORef v_opt_C addWay :: WayName -> IO () -addWay = consIORef v_Ways +addWay = consIORef v_Ways . lkupWay removeOpt :: String -> IO () removeOpt f = do @@ -306,12 +307,6 @@ GLOBAL_VAR(v_Ld_inputs, [], [String]) -- becomes the suffix used to find .hi files and libraries used in -- this compilation. -GLOBAL_VAR(v_Build_tag, "", String) - --- The RTS has its own build tag, because there are some ways that --- affect the RTS only. -GLOBAL_VAR(v_RTS_Build_tag, "", String) - data WayName = WayThreaded | WayDebug @@ -321,26 +316,10 @@ data WayName | WayPar | WayGran | WayNDP - | WayUser_a - | WayUser_b - | WayUser_c - | WayUser_d - | WayUser_e - | WayUser_f - | WayUser_g - | WayUser_h - | WayUser_i - | WayUser_j - | WayUser_k - | WayUser_l - | WayUser_m - | WayUser_n - | WayUser_o - | WayUser_A - | WayUser_B + | WayDyn deriving (Eq,Ord) -GLOBAL_VAR(v_Ways, [] ,[WayName]) +GLOBAL_VAR(v_Ways, [] ,[Way]) allowed_combination :: [WayName] -> Bool allowed_combination way = and [ x `allowedWith` y @@ -350,6 +329,10 @@ allowed_combination way = and [ x `allowedWith` y -- <= the right argument, according to the Ord instance -- on Way above. + -- dyn is allowed with everything + _ `allowedWith` WayDyn = True + WayDyn `allowedWith` _ = True + -- debug is allowed with everything _ `allowedWith` WayDebug = True WayDebug `allowedWith` _ = True @@ -360,33 +343,27 @@ allowed_combination way = and [ x `allowedWith` y _ `allowedWith` _ = False -findBuildTag :: IO [String] -- new options -findBuildTag = do - way_names <- readIORef v_Ways - let ws = sort (nub way_names) +getWayFlags :: IO [String] -- new options +getWayFlags = do + unsorted <- readIORef v_Ways + let ways = sortBy (compare `on` wayName) $ + nubBy ((==) `on` wayName) $ unsorted + writeIORef v_Ways ways - if not (allowed_combination ws) + if not (allowed_combination (map wayName ways)) then ghcError (CmdLineError $ "combination not supported: " ++ foldr1 (\a b -> a ++ '/':b) - (map (wayName . lkupWay) ws)) - else let ways = map lkupWay ws - tag = mkBuildTag (filter (not.wayRTSOnly) ways) - rts_tag = mkBuildTag ways - flags = map wayOpts ways - in do - writeIORef v_Build_tag tag - writeIORef v_RTS_Build_tag rts_tag - return (concat flags) - - + (map wayDesc ways)) + else + return (concatMap wayOpts ways) mkBuildTag :: [Way] -> String mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) lkupWay :: WayName -> Way lkupWay w = - case lookup w way_details of + case listToMaybe (filter ((==) w . wayName) way_details) of Nothing -> error "findBuildTag" Just details -> details @@ -394,15 +371,16 @@ isRTSWay :: WayName -> Bool isRTSWay = wayRTSOnly . lkupWay data Way = Way { + wayName :: WayName, wayTag :: String, wayRTSOnly :: Bool, - wayName :: String, + wayDesc :: String, wayOpts :: [String] } -way_details :: [ (WayName, Way) ] +way_details :: [ Way ] way_details = - [ (WayThreaded, Way "thr" True "Threaded" [ + [ Way WayThreaded "thr" True "Threaded" [ #if defined(freebsd_TARGET_OS) -- "-optc-pthread" -- , "-optl-pthread" @@ -414,25 +392,28 @@ way_details = #elif defined(solaris2_TARGET_OS) "-optl-lrt" #endif - ] ), + ], + + Way WayDebug "debug" True "Debug" [], - (WayDebug, Way "debug" True "Debug" [] ), + Way WayDyn "dyn" False "Dynamic" + [ "-DDYNAMIC" + , "-optc-DDYNAMIC" ], - (WayProf, Way "p" False "Profiling" + Way WayProf "p" False "Profiling" [ "-fscc-profiling" , "-DPROFILING" - , "-optc-DPROFILING" ]), + , "-optc-DPROFILING" ], - (WayEventLog, Way "l" True "RTS Event Logging" + Way WayEventLog "l" True "RTS Event Logging" [ "-DEVENTLOG" - , "-optc-DEVENTLOG" ]), + , "-optc-DEVENTLOG" ], - (WayTicky, Way "t" True "Ticky-ticky Profiling" + Way WayTicky "t" True "Ticky-ticky Profiling" [ "-DTICKY_TICKY" - , "-optc-DTICKY_TICKY" ]), + , "-optc-DTICKY_TICKY" ], - -- optl's below to tell linker where to find the PVM library -- HWL - (WayPar, Way "mp" False "Parallel" + Way WayPar "mp" False "Parallel" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" @@ -440,10 +421,10 @@ way_details = , "-optc-w" , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" , "-optl-lpvm3" - , "-optl-lgpvm3" ]), + , "-optl-lgpvm3" ], -- at the moment we only change the RTS and could share compiler and libs! - (WayPar, Way "mt" False "Parallel ticky profiling" + Way WayPar "mt" False "Parallel ticky profiling" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" @@ -452,9 +433,9 @@ way_details = , "-optc-w" , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" , "-optl-lpvm3" - , "-optl-lgpvm3" ]), + , "-optl-lgpvm3" ], - (WayPar, Way "md" False "Distributed" + Way WayPar "md" False "Distributed" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-D__DISTRIBUTED_HASKELL__" @@ -464,34 +445,15 @@ way_details = , "-optc-w" , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" , "-optl-lpvm3" - , "-optl-lgpvm3" ]), + , "-optl-lgpvm3" ], - (WayGran, Way "mg" False "GranSim" + Way WayGran "mg" False "GranSim" [ "-fgransim" , "-D__GRANSIM__" , "-optc-DGRAN" - , "-package concurrent" ]), + , "-package concurrent" ], - (WayNDP, Way "ndp" False "Nested data parallelism" + Way WayNDP "ndp" False "Nested data parallelism" [ "-XParr" - , "-fvectorise"]), - - (WayUser_a, Way "a" False "User way 'a'" ["$WAY_a_REAL_OPTS"]), - (WayUser_b, Way "b" False "User way 'b'" ["$WAY_b_REAL_OPTS"]), - (WayUser_c, Way "c" False "User way 'c'" ["$WAY_c_REAL_OPTS"]), - (WayUser_d, Way "d" False "User way 'd'" ["$WAY_d_REAL_OPTS"]), - (WayUser_e, Way "e" False "User way 'e'" ["$WAY_e_REAL_OPTS"]), - (WayUser_f, Way "f" False "User way 'f'" ["$WAY_f_REAL_OPTS"]), - (WayUser_g, Way "g" False "User way 'g'" ["$WAY_g_REAL_OPTS"]), - (WayUser_h, Way "h" False "User way 'h'" ["$WAY_h_REAL_OPTS"]), - (WayUser_i, Way "i" False "User way 'i'" ["$WAY_i_REAL_OPTS"]), - (WayUser_j, Way "j" False "User way 'j'" ["$WAY_j_REAL_OPTS"]), - (WayUser_k, Way "k" False "User way 'k'" ["$WAY_k_REAL_OPTS"]), - (WayUser_l, Way "l" False "User way 'l'" ["$WAY_l_REAL_OPTS"]), - (WayUser_m, Way "m" False "User way 'm'" ["$WAY_m_REAL_OPTS"]), - (WayUser_n, Way "n" False "User way 'n'" ["$WAY_n_REAL_OPTS"]), - (WayUser_o, Way "o" False "User way 'o'" ["$WAY_o_REAL_OPTS"]), - (WayUser_A, Way "A" False "User way 'A'" ["$WAY_A_REAL_OPTS"]), - (WayUser_B, Way "B" False "User way 'B'" ["$WAY_B_REAL_OPTS"]) + , "-fvectorise"] ] - |