[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).

diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index b2db529..7d317ac 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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