[project @ 2004-03-05 15:09:37 by stolz]

[ghc-hetmet.git] / ghc / compiler / main / DriverState.hs

diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index b6b527e..c6acf81 100644 (file)
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.98 2004/02/24 17:33:34 simonmar Exp $
+-- $Id: DriverState.hs,v 1.101 2004/03/05 15:09:37 stolz Exp $
 --
 -- Settings for the driver
 --
@@ -521,14 +521,19 @@ GLOBAL_VAR(v_Ways, [] ,[WayName])
 allowed_combination way = and [ x `allowedWith` y 
                              | x <- way, y <- way, x < y ]
   where
+       -- Note ordering in these tests: the left argument is
+       -- <= the right argument, according to the Ord instance
+       -- on Way above.
+
        -- debug is allowed with everything
        _ `allowedWith` WayDebug                = True
        WayDebug `allowedWith` _                = True
 
-       WayProf `allowedWith` WayThreaded       = True
+       WayThreaded `allowedWith` WayProf       = True
        WayProf `allowedWith` WayUnreg          = True
        WayProf `allowedWith` WaySMP            = True
        WayProf `allowedWith` WayNDP            = True
+       _ `allowedWith` _                       = False
 
 
 findBuildTag :: IO [String]  -- new options
@@ -540,15 +545,18 @@ findBuildTag = do
                    "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
+      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)
 
+mkBuildTag :: [Way] -> String
+mkBuildTag ways = concat (intersperse "_" (map wayTag ways))
+
 lkupWay w = 
    case lookup w way_details of
        Nothing -> error "findBuildTag"
@@ -565,7 +573,7 @@ way_details :: [ (WayName, Way) ]
 way_details =
   [ (WayThreaded, Way "thr" True "Threaded" [
 #if defined(freebsd_TARGET_OS)
-       , "-optc-pthread"
+       "-optc-pthread"
 #endif
        ] ),