From cd20fd58e77d3593cd5870a7345285869b2e32f3 Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 24 Feb 2004 17:33:34 +0000 Subject: [PATCH] [project @ 2004-02-24 17:33:32 by simonmar] Experimental support for RTS-only "ways" HEADS UP! This changes the way that the threaded RTS is used, and also the use of debugging RTSs: - We always build threaded and debugging variants of the RTS now. The --enable-threaded-rts configure option is ignored (and will be removed at some point). - New option: -debug enables the debugging RTS - New option: -threaded enables the threaded RTS. When the threaded RTS is stable enough, we might make it the default. The new options just cause a different variant of the RTS to be linked in, and they cause one or two extra options to be enabled too. The implementation is via the usual ways machinery in the compiler, except that these ways are labelled as RTS-only, and so don't require rebuilding all the libraries too. All of this means we can ship threaded and debugging RTSs with GHC, so that users don't need to fetch and build a GHC source tree to use them. I'd like to get this functionality into 6.2.1 if possible, so please test (I'm willing to stretch the definition of "interface change" to accomodate this, since having a threaded RTS available without having to build GHC will be a big win for the Visual Studio project). --- ghc/compiler/main/DriverFlags.hs | 3 + ghc/compiler/main/DriverPipeline.hs | 26 +++++++ ghc/compiler/main/DriverState.hs | 140 ++++++++++++++++++++--------------- ghc/rts/Makefile | 49 +++++++----- ghc/rts/package.conf.in | 15 +++- 5 files changed, 156 insertions(+), 77 deletions(-) diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index b2db529..7d317ac 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -201,8 +201,11 @@ static_flags = , ( "smp" , NoArg (addNoDups v_Ways WaySMP) ) , ( "debug" , NoArg (addNoDups v_Ways WayDebug) ) , ( "ndp" , NoArg (addNoDups v_Ways WayNDP) ) + , ( "threaded" , NoArg (addNoDups v_Ways WayThreaded) ) -- ToDo: user ways + ------ RTS ways ----------------------------------------------------- + ------ Debugging ---------------------------------------------------- , ( "dppr-noprags", PassFlag (add v_Opt_C) ) , ( "dppr-debug", PassFlag (add v_Opt_C) ) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index d4cb66a..4521e34 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1027,6 +1027,30 @@ staticLink o_files dep_packages = do [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage] + ways <- readIORef v_Ways + + -- 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 = [ +#if defined(HAVE_LIBBFD) + "-lbfd", "-liberty" +#endif + ] + | otherwise = [] + + let + thread_opts | WayThreaded `elem` ways = [ +#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) + "-lpthread" +#endif +#if defined(osf3_TARGET_OS) + , "-lexc" +#endif + ] + | otherwise = [] + let extra_os = if static || no_hs_main then [] else [ head (library_dirs rts_pkg) ++ "/Main.dll_o", @@ -1054,6 +1078,8 @@ staticLink o_files dep_packages = do ++ pkg_framework_path_opts ++ pkg_framework_opts #endif + ++ debug_opts + ++ thread_opts )) -- parallel only: move binary to another dir -- HWL diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 74d82e8..b6b527e 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.97 2003/09/23 14:33:00 simonmar Exp $ +-- $Id: DriverState.hs,v 1.98 2004/02/24 17:33:34 simonmar Exp $ -- -- Settings for the driver -- @@ -379,16 +379,23 @@ getPackageLinkOpts :: [PackageName] -> IO [String] getPackageLinkOpts pkgs = do ps <- getExplicitPackagesAnd pkgs tag <- readIORef v_Build_tag + rts_tag <- readIORef v_RTS_Build_tag static <- readIORef v_Static let imp = if static then "" else "_imp" - suffix = if null tag then "" else '_':tag - libs p = map (++suffix) (hACK (hs_libraries p)) ++ extra_libraries p + libs p = map addSuffix (hACK (hs_libraries p)) ++ extra_libraries p imp_libs p = map (++imp) (libs p) all_opts p = map ("-l" ++) (imp_libs p) ++ extra_ld_opts p + suffix = if null tag then "" else '_':tag + rts_suffix = if null rts_tag then "" else '_':rts_tag + + addSuffix rts@"HSrts" = rts ++ rts_suffix + addSuffix other_lib = other_lib ++ suffix + return (concat (map all_opts ps)) where + -- This is a totally horrible (temporary) hack, for Win32. Problem is -- that package.conf for Win32 says that the main prelude lib is -- split into HSbase1, HSbase2 and HSbase3, which is needed due to a bug @@ -476,15 +483,20 @@ getExplicitAndAutoPackageConfigs = do 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 - = WayProf + = WayThreaded + | WayDebug + | WayProf | WayUnreg | WayTicky | WayPar | WayGran | WaySMP | WayNDP - | WayDebug | WayUser_a | WayUser_b | WayUser_c @@ -506,35 +518,36 @@ data WayName GLOBAL_VAR(v_Ways, [] ,[WayName]) -allowed_combination way = way `elem` combs - where -- the sub-lists must be ordered according to WayName, - -- because findBuildTag sorts them - combs = [ [WayProf, WayUnreg], - [WayProf, WaySMP] , - [WayProf, WayNDP] ] +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + WayProf `allowedWith` WayThreaded = True + WayProf `allowedWith` WayUnreg = True + WayProf `allowedWith` WaySMP = True + WayProf `allowedWith` WayNDP = True + findBuildTag :: IO [String] -- new options findBuildTag = do way_names <- readIORef v_Ways - case sort way_names of - [] -> do -- writeIORef v_Build_tag "" - return [] - - [w] -> do let details = lkupWay w - writeIORef v_Build_tag (wayTag details) - return (wayOpts details) - - ws -> if not (allowed_combination ws) - then throwDyn (CmdLineError $ - "combination not supported: " ++ - foldr1 (\a b -> a ++ '/':b) - (map (wayName . lkupWay) ws)) - else let stuff = map lkupWay ws - tag = concat (map wayTag stuff) - flags = map wayOpts stuff - in do - writeIORef v_Build_tag tag - return (concat flags) + let ws = sort way_names + if not (allowed_combination ws) + then throwDyn (CmdLineError $ + "combination not supported: " ++ + foldr1 (\a b -> a ++ '/':b) + (map (wayName . lkupWay) ws)) + else let stuff = map lkupWay ws + tag = concat [ wayTag w | w <- stuff, not (wayRTSOnly w) ] + rts_tag = concat (map wayTag stuff) + flags = map wayOpts stuff + in do + writeIORef v_Build_tag tag + writeIORef v_RTS_Build_tag rts_tag + return (concat flags) lkupWay w = case lookup w way_details of @@ -542,30 +555,39 @@ lkupWay w = Just details -> details data Way = Way { - wayTag :: String, - wayName :: String, - wayOpts :: [String] + wayTag :: String, + wayRTSOnly :: Bool, + wayName :: String, + wayOpts :: [String] } way_details :: [ (WayName, Way) ] way_details = - [ (WayProf, Way "p" "Profiling" + [ (WayThreaded, Way "thr" True "Threaded" [ +#if defined(freebsd_TARGET_OS) + , "-optc-pthread" +#endif + ] ), + + (WayDebug, Way "debug" True "Debug" [] ), + + (WayProf, Way "p" False "Profiling" [ "-fscc-profiling" , "-DPROFILING" , "-optc-DPROFILING" , "-fvia-C" ]), - (WayTicky, Way "t" "Ticky-ticky Profiling" + (WayTicky, Way "t" False "Ticky-ticky Profiling" [ "-fticky-ticky" , "-DTICKY_TICKY" , "-optc-DTICKY_TICKY" , "-fvia-C" ]), - (WayUnreg, Way "u" "Unregisterised" + (WayUnreg, Way "u" False "Unregisterised" unregFlags ), -- optl's below to tell linker where to find the PVM library -- HWL - (WayPar, Way "mp" "Parallel" + (WayPar, Way "mp" False "Parallel" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" @@ -577,7 +599,7 @@ way_details = , "-fvia-C" ]), -- at the moment we only change the RTS and could share compiler and libs! - (WayPar, Way "mt" "Parallel ticky profiling" + (WayPar, Way "mt" False "Parallel ticky profiling" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-optc-DPAR" @@ -589,7 +611,7 @@ way_details = , "-optl-lgpvm3" , "-fvia-C" ]), - (WayPar, Way "md" "Distributed" + (WayPar, Way "md" False "Distributed" [ "-fparallel" , "-D__PARALLEL_HASKELL__" , "-D__DISTRIBUTED_HASKELL__" @@ -602,14 +624,14 @@ way_details = , "-optl-lgpvm3" , "-fvia-C" ]), - (WayGran, Way "mg" "GranSim" + (WayGran, Way "mg" False "GranSim" [ "-fgransim" , "-D__GRANSIM__" , "-optc-DGRAN" , "-package concurrent" , "-fvia-C" ]), - (WaySMP, Way "s" "SMP" + (WaySMP, Way "s" False "SMP" [ "-fsmp" , "-optc-pthread" #ifndef freebsd_TARGET_OS @@ -618,27 +640,27 @@ way_details = , "-optc-DSMP" , "-fvia-C" ]), - (WayNDP, Way "ndp" "Nested data parallelism" + (WayNDP, Way "ndp" False "Nested data parallelism" [ "-fparr" , "-fflatten"]), - (WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]), - (WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]), - (WayUser_c, Way "c" "User way 'c'" ["$WAY_c_REAL_OPTS"]), - (WayUser_d, Way "d" "User way 'd'" ["$WAY_d_REAL_OPTS"]), - (WayUser_e, Way "e" "User way 'e'" ["$WAY_e_REAL_OPTS"]), - (WayUser_f, Way "f" "User way 'f'" ["$WAY_f_REAL_OPTS"]), - (WayUser_g, Way "g" "User way 'g'" ["$WAY_g_REAL_OPTS"]), - (WayUser_h, Way "h" "User way 'h'" ["$WAY_h_REAL_OPTS"]), - (WayUser_i, Way "i" "User way 'i'" ["$WAY_i_REAL_OPTS"]), - (WayUser_j, Way "j" "User way 'j'" ["$WAY_j_REAL_OPTS"]), - (WayUser_k, Way "k" "User way 'k'" ["$WAY_k_REAL_OPTS"]), - (WayUser_l, Way "l" "User way 'l'" ["$WAY_l_REAL_OPTS"]), - (WayUser_m, Way "m" "User way 'm'" ["$WAY_m_REAL_OPTS"]), - (WayUser_n, Way "n" "User way 'n'" ["$WAY_n_REAL_OPTS"]), - (WayUser_o, Way "o" "User way 'o'" ["$WAY_o_REAL_OPTS"]), - (WayUser_A, Way "A" "User way 'A'" ["$WAY_A_REAL_OPTS"]), - (WayUser_B, Way "B" "User way 'B'" ["$WAY_B_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"]), + (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"]) ] unregFlags = diff --git a/ghc/rts/Makefile b/ghc/rts/Makefile index 6a75b87..63fc69e 100644 --- a/ghc/rts/Makefile +++ b/ghc/rts/Makefile @@ -24,11 +24,41 @@ UseGhcForCc = YES include $(TOP)/mk/boilerplate.mk +PACKAGE = rts + HC=$(GHC_INPLACE) -WAYS=$(GhcLibWays) +# ----------------------------------------------------------------------------- +# RTS ways -PACKAGE = rts +WAYS=$(GhcLibWays) thr debug + +ifneq "$(findstring p, $(GhcLibWays))" "" +WAYS += thr_p debug_p +endif + +# Way 'thr': +WAY_thr_NAME=threaded +WAY_thr_HC_OPTS=-optc-DTHREADED_RTS + +# Way 'thr_p': +WAY_thr_p_NAME=threaded profiled +WAY_thr_p_HC_OPTS=-optc-DTHREADED_RTS -prof + +# Way 'debug': +WAY_debug_NAME=debug +WAY_debug_HC_OPTS=-optc-DDEBUG + +# Way 'debug_p': +WAY_debug_p_NAME=debug profiled +WAY_debug_p_HC_OPTS=-optc-DDEBUG -prof + +ifneq "$(findstring $(way), debug debug_p)" "" +GhcRtsHcOpts= +GhcRtsCcOpts=-g +endif + +# ----------------------------------------------------------------------------- # Tells the build system not to add various Haskellish options to $(SRC_HC_OPTS) NON_HS_PACKAGE = YES @@ -110,21 +140,6 @@ ifeq "$(way)" "mp" SRC_HC_OPTS += -I$$PVM_ROOT/include endif -# You get 'threads support' in the normal -# and profiling ways. -ifeq "$(GhcRtsThreaded)" "YES" -ifeq "$(way)" "" -SRC_CC_OPTS += -DTHREADED_RTS -SRC_HC_OPTS += -optc-DTHREADED_RTS -PACKAGE_CPP_OPTS += -DTHREADED_RTS -endif -ifeq "$(way)" "p" -SRC_CC_OPTS += -DTHREADED_RTS -SRC_HC_OPTS += -optc-DTHREADED_RTS -PACKAGE_CPP_OPTS += -DTHREADED_RTS -endif -endif - # If -DDEBUG is in effect, adjust package conf accordingly.. ifneq "$(strip $(filter -optc-DDEBUG,$(GhcRtsHcOpts)))" "" PACKAGE_CPP_OPTS += -DDEBUG diff --git a/ghc/rts/package.conf.in b/ghc/rts/package.conf.in index ac11847..341f36b 100644 --- a/ghc/rts/package.conf.in +++ b/ghc/rts/package.conf.in @@ -1,8 +1,15 @@ #include "config.h" #include "Derived.h" +/* The RTS is just another package! */ Package { - name = "rts", /* The RTS is just another package! */ +#ifdef THREADED_RTS + name = "rts_thr", +#elif defined(DEBUG) + name = "rts_debug", +#else + name = "rts", +#endif import_dirs = [], source_dirs = [], @@ -20,7 +27,13 @@ Package { #endif ], +#ifdef THREADED_RTS + hs_libraries = [ "HSrts_thr" ], +#elif defined(DEBUG) + hs_libraries = [ "HSrts_debug" ], +#else hs_libraries = [ "HSrts" ], +#endif extra_libraries = [ "m" /* for ldexp() */ #ifndef HAVE_FRAMEWORK_HASKELLSUPPORT -- 1.7.10.4