ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.59 2001/10/01 14:28:37 rrt Exp $
   3 --
   4 -- Settings for the driver
   5 --
   6 -- (c) The University of Glasgow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverState where
  11
  12 #include "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import SysTools         ( getTopDir )
  16 import ParsePkgConf     ( loadPackageConfig )
  17 import Packages         ( PackageConfig(..), mungePackagePaths )
  18 import CmdLineOpts
  19 import DriverPhases
  20 import DriverUtil
  21 import Util
  22 import Config
  23 import Exception
  24 import IOExts
  25 import Panic
  26
  27 import List
  28 import Char
  29 import Monad
  30 import Directory ( doesDirectoryExist )
  31
  32 -----------------------------------------------------------------------------
  33 -- non-configured things
  34
  35 cHaskell1Version = "5" -- i.e., Haskell 98
  36
  37 -----------------------------------------------------------------------------
  38 -- GHC modes of operation
  39
  40 data GhcMode
  41   = DoMkDependHS                        -- ghc -M
  42   | DoMkDLL                             -- ghc --mk-dll
  43   | StopBefore Phase                    -- ghc -E | -C | -S | -c
  44   | DoMake                              -- ghc --make
  45   | DoInteractive                       -- ghc --interactive
  46   | DoLink                              -- [ the default ]
  47   deriving (Eq)
  48
  49 GLOBAL_VAR(v_GhcMode, error "mode not set", GhcMode)
  50
  51 -----------------------------------------------------------------------------
  52 -- Global compilation flags
  53
  54 -- Cpp-related flags
  55 v_Hs_source_cpp_opts = global
  56         [ "-D__HASKELL1__="++cHaskell1Version
  57         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
  58         , "-D__HASKELL98__"
  59         , "-D__CONCURRENT_HASKELL__"
  60         ]
  61 {-# NOINLINE v_Hs_source_cpp_opts #-}
  62
  63 -- Keep output from intermediate phases
  64 GLOBAL_VAR(v_Keep_hi_diffs,             False,          Bool)
  65 GLOBAL_VAR(v_Keep_hc_files,             False,          Bool)
  66 GLOBAL_VAR(v_Keep_il_files,             False,          Bool)
  67 GLOBAL_VAR(v_Keep_s_files,              False,          Bool)
  68 GLOBAL_VAR(v_Keep_raw_s_files,          False,          Bool)
  69 GLOBAL_VAR(v_Keep_tmp_files,            False,          Bool)
  70
  71 -- Misc
  72 GLOBAL_VAR(v_Scale_sizes_by,            1.0,            Double)
  73 GLOBAL_VAR(v_Static,                    True,           Bool)
  74 GLOBAL_VAR(v_NoHsMain,                  False,          Bool)
  75 GLOBAL_VAR(v_Recomp,                    True,           Bool)
  76 GLOBAL_VAR(v_Collect_ghc_timing,        False,          Bool)
  77 GLOBAL_VAR(v_Do_asm_mangling,           True,           Bool)
  78 GLOBAL_VAR(v_Excess_precision,          False,          Bool)
  79 GLOBAL_VAR(v_Read_DotGHCi,              True,           Bool)
  80
  81 -----------------------------------------------------------------------------
  82 -- Splitting object files (for libraries)
  83
  84 GLOBAL_VAR(v_Split_object_files,        False,          Bool)
  85 GLOBAL_VAR(v_Split_info,                ("",0),         (String,Int))
  86         -- The split prefix and number of files
  87
  88
  89 can_split :: Bool
  90 can_split =  prefixMatch "i386"    cTARGETPLATFORM
  91           || prefixMatch "alpha"   cTARGETPLATFORM
  92           || prefixMatch "hppa"    cTARGETPLATFORM
  93           || prefixMatch "m68k"    cTARGETPLATFORM
  94           || prefixMatch "mips"    cTARGETPLATFORM
  95           || prefixMatch "powerpc" cTARGETPLATFORM
  96           || prefixMatch "rs6000"  cTARGETPLATFORM
  97           || prefixMatch "sparc"   cTARGETPLATFORM
  98
  99 -----------------------------------------------------------------------------
 100 -- Compiler output options
 101
 102 defaultHscLang
 103   | cGhcWithNativeCodeGen == "YES" &&
 104         (prefixMatch "i386" cTARGETPLATFORM ||
 105          prefixMatch "sparc" cTARGETPLATFORM)   =  HscAsm
 106   | otherwise                                   =  HscC
 107
 108 GLOBAL_VAR(v_Output_dir,  Nothing, Maybe String)
 109 GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
 110 GLOBAL_VAR(v_Output_hi,   Nothing, Maybe String)
 111
 112 GLOBAL_VAR(v_Object_suf,  Nothing, Maybe String)
 113 GLOBAL_VAR(v_HC_suf,      Nothing, Maybe String)
 114 GLOBAL_VAR(v_Hi_dir,      Nothing, Maybe String)
 115 GLOBAL_VAR(v_Hi_suf,      "hi",    String)
 116
 117 GLOBAL_VAR(v_Ld_inputs, [],      [String])
 118
 119 odir_ify :: String -> IO String
 120 odir_ify f = do
 121   odir_opt <- readIORef v_Output_dir
 122   case odir_opt of
 123         Nothing -> return f
 124         Just d  -> return (newdir d f)
 125
 126 osuf_ify :: String -> IO String
 127 osuf_ify f = do
 128   osuf_opt <- readIORef v_Object_suf
 129   case osuf_opt of
 130         Nothing -> return f
 131         Just s  -> return (newsuf s f)
 132
 133 -----------------------------------------------------------------------------
 134 -- Compiler optimisation options
 135
 136 GLOBAL_VAR(v_OptLevel, 0, Int)
 137
 138 setOptLevel :: String -> IO ()
 139 setOptLevel ""              = do { writeIORef v_OptLevel 1 }
 140 setOptLevel "not"           = writeIORef v_OptLevel 0
 141 setOptLevel [c] | isDigit c = do
 142    let level = ord c - ord '0'
 143    writeIORef v_OptLevel level
 144 setOptLevel s = unknownFlagErr ("-O"++s)
 145
 146 GLOBAL_VAR(v_minus_o2_for_C,            False, Bool)
 147 GLOBAL_VAR(v_MaxSimplifierIterations,   4,     Int)
 148 GLOBAL_VAR(v_StgStats,                  False, Bool)
 149 GLOBAL_VAR(v_UsageSPInf,                False, Bool)  -- Off by default
 150 GLOBAL_VAR(v_Strictness,                True,  Bool)
 151 GLOBAL_VAR(v_CPR,                       True,  Bool)
 152 GLOBAL_VAR(v_CSE,                       True,  Bool)
 153 GLOBAL_VAR(v_RuleCheck,                 Nothing,  Maybe String)
 154
 155 -- these are the static flags you get without -O.
 156 hsc_minusNoO_flags =
 157        [
 158         "-fignore-interface-pragmas",
 159         "-fomit-interface-pragmas",
 160         "-fdo-lambda-eta-expansion",    -- This one is important for a tiresome reason:
 161                                         -- we want to make sure that the bindings for data
 162                                         -- constructors are eta-expanded.  This is probably
 163                                         -- a good thing anyway, but it seems fragile.
 164         "-flet-no-escape"
 165         ]
 166
 167 -- these are the static flags you get when -O is on.
 168 hsc_minusO_flags =
 169   [
 170         "-fignore-asserts",
 171         "-ffoldr-build-on",
 172         "-fdo-eta-reduction",
 173         "-fdo-lambda-eta-expansion",
 174         "-fcase-merge",
 175         "-flet-to-case",
 176         "-flet-no-escape"
 177    ]
 178
 179 hsc_minusO2_flags = hsc_minusO_flags    -- for now
 180
 181 getStaticOptimisationFlags 0 = hsc_minusNoO_flags
 182 getStaticOptimisationFlags 1 = hsc_minusO_flags
 183 getStaticOptimisationFlags n = hsc_minusO2_flags
 184
 185 buildCoreToDo :: IO [CoreToDo]
 186 buildCoreToDo = do
 187    opt_level  <- readIORef v_OptLevel
 188    max_iter   <- readIORef v_MaxSimplifierIterations
 189    usageSP    <- readIORef v_UsageSPInf
 190    strictness <- readIORef v_Strictness
 191    cpr        <- readIORef v_CPR
 192    cse        <- readIORef v_CSE
 193    rule_check <- readIORef v_RuleCheck
 194
 195    if opt_level == 0 then return
 196       [
 197         CoreDoSimplify (SimplPhase 0) [
 198             MaxSimplifierIterations max_iter
 199         ]
 200       ]
 201
 202     else {- opt_level >= 1 -} return [
 203
 204         -- initial simplify: mk specialiser happy: minimum effort please
 205         CoreDoSimplify SimplGently [
 206                         --      Simplify "gently"
 207                         -- Don't inline anything till full laziness has bitten
 208                         -- In particular, inlining wrappers inhibits floating
 209                         -- e.g. ...(case f x of ...)...
 210                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
 211                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
 212                         -- and now the redex (f x) isn't floatable any more
 213                         -- Similarly, don't apply any rules until after full
 214                         -- laziness.  Notably, list fusion can prevent floating.
 215
 216             NoCaseOfCase,
 217                         -- Don't do case-of-case transformations.
 218                         -- This makes full laziness work better
 219             MaxSimplifierIterations max_iter
 220         ],
 221
 222         -- Specialisation is best done before full laziness
 223         -- so that overloaded functions have all their dictionary lambdas manifest
 224         CoreDoSpecialising,
 225
 226         CoreDoFloatOutwards False{-not full-},
 227         CoreDoFloatInwards,
 228
 229         CoreDoSimplify (SimplPhase 2) [
 230                 -- Want to run with inline phase 2 after the specialiser to give
 231                 -- maximum chance for fusion to work before we inline build/augment
 232                 -- in phase 1.  This made a difference in 'ansi' where an
 233                 -- overloaded function wasn't inlined till too late.
 234            MaxSimplifierIterations max_iter
 235         ],
 236         case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
 237
 238         -- infer usage information here in case we need it later.
 239         -- (add more of these where you need them --KSW 1999-04)
 240         if usageSP then CoreDoUSPInf else CoreDoNothing,
 241
 242         CoreDoSimplify (SimplPhase 1) [
 243                 -- Need inline-phase2 here so that build/augment get
 244                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 245                 -- strictness in the function sumcode' if augment is not inlined
 246                 -- before strictness analysis runs
 247            MaxSimplifierIterations max_iter
 248         ],
 249         case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
 250
 251         CoreDoSimplify (SimplPhase 0) [
 252                 -- Phase 0: allow all Ids to be inlined now
 253                 -- This gets foldr inlined before strictness analysis
 254
 255            MaxSimplifierIterations 3
 256                 -- At least 3 iterations because otherwise we land up with
 257                 -- huge dead expressions because of an infelicity in the
 258                 -- simpifier.
 259                 --      let k = BIG in foldr k z xs
 260                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
 261                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
 262                 -- Don't stop now!
 263
 264         ],
 265         case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
 266
 267         if cpr        then CoreDoCPResult   else CoreDoNothing,
 268         if strictness then CoreDoStrictness else CoreDoNothing,
 269         CoreDoWorkerWrapper,
 270         CoreDoGlomBinds,
 271
 272         CoreDoSimplify (SimplPhase 0) [
 273            MaxSimplifierIterations max_iter
 274         ],
 275
 276         CoreDoFloatOutwards False{-not full-},
 277                 -- nofib/spectral/hartel/wang doubles in speed if you
 278                 -- do full laziness late in the day.  It only happens
 279                 -- after fusion and other stuff, so the early pass doesn't
 280                 -- catch it.  For the record, the redex is
 281                 --        f_el22 (f_el21 r_midblock)
 282
 283
 284 -- Leave out lambda lifting for now
 285 --        "-fsimplify", -- Tidy up results of full laziness
 286 --          "[",
 287 --                "-fmax-simplifier-iterations2",
 288 --          "]",
 289 --        "-ffloat-outwards-full",
 290
 291         -- We want CSE to follow the final full-laziness pass, because it may
 292         -- succeed in commoning up things floated out by full laziness.
 293         -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
 294
 295         if cse then CoreCSE else CoreDoNothing,
 296
 297         CoreDoFloatInwards,
 298
 299 -- Case-liberation for -O2.  This should be after
 300 -- strictness analysis and the simplification which follows it.
 301
 302         case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
 303
 304         if opt_level >= 2 then
 305            CoreLiberateCase
 306         else
 307            CoreDoNothing,
 308         if opt_level >= 2 then
 309            CoreDoSpecConstr
 310         else
 311            CoreDoNothing,
 312
 313         -- Final clean-up simplification:
 314         CoreDoSimplify (SimplPhase 0) [
 315           MaxSimplifierIterations max_iter
 316         ]
 317      ]
 318
 319 buildStgToDo :: IO [ StgToDo ]
 320 buildStgToDo = do
 321   stg_stats <- readIORef v_StgStats
 322   let flags1 | stg_stats = [ D_stg_stats ]
 323              | otherwise = [ ]
 324
 325         -- STG passes
 326   ways_ <- readIORef v_Ways
 327   let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
 328              | otherwise            = flags1
 329
 330   return flags2
 331
 332 -----------------------------------------------------------------------------
 333 -- Paths & Libraries
 334
 335 split_marker = ':'   -- not configurable (ToDo)
 336
 337 v_Import_paths, v_Include_paths, v_Library_paths :: IORef [String]
 338 GLOBAL_VAR(v_Import_paths,  ["."], [String])
 339 GLOBAL_VAR(v_Include_paths, ["."], [String])
 340 GLOBAL_VAR(v_Library_paths, [],  [String])
 341
 342 GLOBAL_VAR(v_Cmdline_libraries,   [], [String])
 343
 344 addToDirList :: IORef [String] -> String -> IO ()
 345 addToDirList ref path
 346   = do paths           <- readIORef ref
 347        shiny_new_ones  <- splitUp path
 348        writeIORef ref (paths ++ shiny_new_ones)
 349
 350   where
 351     splitUp ::String -> IO [String]
 352 #ifdef mingw32_TARGET_OS
 353      -- 'hybrid' support for DOS-style paths in directory lists.
 354      --
 355      -- That is, if "foo:bar:baz" is used, this interpreted as
 356      -- consisting of three entries, 'foo', 'bar', 'baz'.
 357      -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted
 358      -- as four elts, "c:/foo", "c:\\foo", "x", and "/bar" --
 359      -- *provided* c:/foo exists and x:/bar doesn't.
 360      --
 361      -- Notice that no attempt is made to fully replace the 'standard'
 362      -- split marker ':' with the Windows / DOS one, ';'. The reason being
 363      -- that this will cause too much breakage for users & ':' will
 364      -- work fine even with DOS paths, if you're not insisting on being silly.
 365      -- So, use either.
 366     splitUp []         = return []
 367     splitUp (x:':':div:xs)
 368       | div `elem` dir_markers = do
 369           let (p,rs) = findNextPath xs
 370           ps  <- splitUp rs
 371            {-
 372              Consult the file system to check the interpretation
 373              of (x:':':div:p) -- this is arguably excessive, we
 374              could skip this test & just say that it is a valid
 375              dir path.
 376            -}
 377           flg <- doesDirectoryExist (x:':':div:p)
 378           if flg then
 379              return ((x:':':div:p):ps)
 380            else
 381              return ([x]:(div:p):ps)
 382     splitUp xs = do
 383       let (p,rs) = findNextPath xs
 384       ps <- splitUp rs
 385       return (cons p ps)
 386
 387     cons "" xs = xs
 388     cons x  xs = x:xs
 389
 390     -- will be called either when we've consumed nought or the "<Drive>:/" part of
 391     -- a DOS path, so splitting is just a Q of finding the next split marker.
 392     findNextPath xs =
 393         case break (`elem` split_markers) xs of
 394            (p, d:ds) -> (p, ds)
 395            (p, xs)   -> (p, xs)
 396
 397     split_markers :: [Char]
 398     split_markers = [':', ';']
 399
 400     dir_markers :: [Char]
 401     dir_markers = ['/', '\\']
 402
 403 #else
 404     splitUp xs = return (split split_marker xs)
 405 #endif
 406
 407 GLOBAL_VAR(v_HCHeader, "", String)
 408
 409 -----------------------------------------------------------------------------
 410 -- Packages
 411
 412 -- package list is maintained in dependency order
 413 GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String])
 414
 415 readPackageConf :: String -> IO ()
 416 readPackageConf conf_file = do
 417   proto_pkg_details <- loadPackageConfig conf_file
 418   top_dir <- getTopDir
 419   let pkg_details    = mungePackagePaths top_dir proto_pkg_details
 420   old_pkg_details <- readIORef v_Package_details
 421   let intersection = filter (`elem` map name old_pkg_details)
 422                                 (map name pkg_details)
 423   if (not (null intersection))
 424         then throwDyn (InstallationError ("package `" ++ head intersection ++ "' is already defined"))
 425         else do
 426   writeIORef v_Package_details (pkg_details ++ old_pkg_details)
 427
 428 addPackage :: String -> IO ()
 429 addPackage package
 430   = do pkg_details <- readIORef v_Package_details
 431        case lookupPkg package pkg_details of
 432           Nothing -> throwDyn (CmdLineError ("unknown package name: " ++ package))
 433           Just details -> do
 434             ps <- readIORef v_Packages
 435             unless (package `elem` ps) $ do
 436                 mapM_ addPackage (package_deps details)
 437                 ps <- readIORef v_Packages
 438                 writeIORef v_Packages (package:ps)
 439
 440 getPackageImportPath   :: IO [String]
 441 getPackageImportPath = do
 442   ps <- getPackageInfo
 443   return (nub (filter (not.null) (concatMap import_dirs ps)))
 444
 445 getPackageIncludePath   :: IO [String]
 446 getPackageIncludePath = do
 447   ps <- getPackageInfo
 448   return (nub (filter (not.null) (concatMap include_dirs ps)))
 449
 450         -- includes are in reverse dependency order (i.e. rts first)
 451 getPackageCIncludes   :: IO [String]
 452 getPackageCIncludes = do
 453   ps <- getPackageInfo
 454   return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
 455
 456 getPackageLibraryPath  :: IO [String]
 457 getPackageLibraryPath = do
 458   ps <- getPackageInfo
 459   return (nub (filter (not.null) (concatMap library_dirs ps)))
 460
 461 getPackageLibraries    :: IO [String]
 462 getPackageLibraries = do
 463   ps <- getPackageInfo
 464   tag <- readIORef v_Build_tag
 465   let suffix = if null tag then "" else '_':tag
 466   return (concat (
 467         map (\p -> map (++suffix) (hACK (hs_libraries p)) ++ extra_libraries p) ps
 468      ))
 469   where
 470      -- This is a totally horrible (temporary) hack, for Win32.  Problem is
 471      -- that package.conf for Win32 says that the main prelude lib is
 472      -- split into HSstd1 and HSstd2, which is needed due to limitations in
 473      -- the PEi386 file format, to make GHCi work.  However, we still only
 474      -- have HSstd.a for static linking, not HSstd1.a and HSstd2.a.
 475      -- getPackageLibraries is called to find the .a's to add to the static
 476      -- link line.  On Win32, this hACK detects HSstd1 and HSstd2 and
 477      -- replaces them with HSstd, so static linking still works.
 478      -- Libraries needed for dynamic (GHCi) linking are discovered via
 479      -- different route (in InteractiveUI.linkPackage).
 480      -- See driver/PackageSrc.hs for the HSstd1/HSstd2 split definition.
 481      -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...)
 482      -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2]
 483      hACK libs
 484 #      ifndef mingw32_TARGET_OS
 485        = libs
 486 #      else
 487        = if   "HSstd1" `elem` libs && "HSstd2" `elem` libs
 488          then "HSstd" : filter ((/= "HSstd").(take 5)) libs
 489          else
 490          if   "HSwin321" `elem` libs && "HSwin322" `elem` libs
 491          then "HSwin32" : filter ((/= "HSwin32").(take 7)) libs
 492          else
 493          libs
 494 #      endif
 495
 496 getPackageExtraGhcOpts :: IO [String]
 497 getPackageExtraGhcOpts = do
 498   ps <- getPackageInfo
 499   return (concatMap extra_ghc_opts ps)
 500
 501 getPackageExtraCcOpts  :: IO [String]
 502 getPackageExtraCcOpts = do
 503   ps <- getPackageInfo
 504   return (concatMap extra_cc_opts ps)
 505
 506 getPackageExtraLdOpts  :: IO [String]
 507 getPackageExtraLdOpts = do
 508   ps <- getPackageInfo
 509   return (concatMap extra_ld_opts ps)
 510
 511 getPackageInfo :: IO [PackageConfig]
 512 getPackageInfo = do
 513   ps <- readIORef v_Packages
 514   getPackageDetails ps
 515
 516 getPackageDetails :: [String] -> IO [PackageConfig]
 517 getPackageDetails ps = do
 518   pkg_details <- readIORef v_Package_details
 519   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 520
 521 GLOBAL_VAR(v_Package_details, [], [PackageConfig])
 522
 523 lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig
 524 lookupPkg nm ps
 525    = case [p | p <- ps, name p == nm] of
 526         []    -> Nothing
 527         (p:_) -> Just p
 528
 529 -----------------------------------------------------------------------------
 530 -- Ways
 531
 532 -- The central concept of a "way" is that all objects in a given
 533 -- program must be compiled in the same "way".  Certain options change
 534 -- parameters of the virtual machine, eg. profiling adds an extra word
 535 -- to the object header, so profiling objects cannot be linked with
 536 -- non-profiling objects.
 537
 538 -- After parsing the command-line options, we determine which "way" we
 539 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 540
 541 -- We then find the "build-tag" associated with this way, and this
 542 -- becomes the suffix used to find .hi files and libraries used in
 543 -- this compilation.
 544
 545 GLOBAL_VAR(v_Build_tag, "", String)
 546
 547 data WayName
 548   = WayProf
 549   | WayUnreg
 550   | WayTicky
 551   | WayPar
 552   | WayGran
 553   | WaySMP
 554   | WayDebug
 555   | WayUser_a
 556   | WayUser_b
 557   | WayUser_c
 558   | WayUser_d
 559   | WayUser_e
 560   | WayUser_f
 561   | WayUser_g
 562   | WayUser_h
 563   | WayUser_i
 564   | WayUser_j
 565   | WayUser_k
 566   | WayUser_l
 567   | WayUser_m
 568   | WayUser_n
 569   | WayUser_o
 570   | WayUser_A
 571   | WayUser_B
 572   deriving (Eq,Ord)
 573
 574 GLOBAL_VAR(v_Ways, [] ,[WayName])
 575
 576 allowed_combination way = way `elem` combs
 577   where  -- the sub-lists must be ordered according to WayName,
 578          -- because findBuildTag sorts them
 579     combs                = [ [WayProf,WayUnreg], [WayProf,WaySMP] ]
 580
 581 findBuildTag :: IO [String]  -- new options
 582 findBuildTag = do
 583   way_names <- readIORef v_Ways
 584   case sort way_names of
 585      []  -> do  -- writeIORef v_Build_tag ""
 586                 return []
 587
 588      [w] -> do let details = lkupWay w
 589                writeIORef v_Build_tag (wayTag details)
 590                return (wayOpts details)
 591
 592      ws  -> if not (allowed_combination ws)
 593                 then throwDyn (CmdLineError $
 594                                 "combination not supported: "  ++
 595                                 foldr1 (\a b -> a ++ '/':b)
 596                                 (map (wayName . lkupWay) ws))
 597                 else let stuff = map lkupWay ws
 598                          tag   = concat (map wayTag stuff)
 599                          flags = map wayOpts stuff
 600                      in do
 601                      writeIORef v_Build_tag tag
 602                      return (concat flags)
 603
 604 lkupWay w =
 605    case lookup w way_details of
 606         Nothing -> error "findBuildTag"
 607         Just details -> details
 608
 609 data Way = Way {
 610   wayTag   :: String,
 611   wayName  :: String,
 612   wayOpts  :: [String]
 613   }
 614
 615 way_details :: [ (WayName, Way) ]
 616 way_details =
 617   [ (WayProf, Way  "p" "Profiling"
 618         [ "-fscc-profiling"
 619         , "-DPROFILING"
 620         , "-optc-DPROFILING"
 621         , "-fvia-C" ]),
 622
 623     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 624         [ "-fticky-ticky"
 625         , "-DTICKY_TICKY"
 626         , "-optc-DTICKY_TICKY"
 627         , "-fvia-C" ]),
 628
 629     (WayUnreg, Way  "u" "Unregisterised"
 630         unregFlags ),
 631
 632     -- optl's below to tell linker where to find the PVM library -- HWL
 633     (WayPar, Way  "mp" "Parallel"
 634         [ "-fparallel"
 635         , "-D__PARALLEL_HASKELL__"
 636         , "-optc-DPAR"
 637         , "-package concurrent"
 638         , "-optc-w"
 639         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 640         , "-optl-lpvm3"
 641         , "-optl-lgpvm3"
 642         , "-fvia-C" ]),
 643
 644     -- at the moment we only change the RTS and could share compiler and libs!
 645     (WayPar, Way  "mt" "Parallel ticky profiling"
 646         [ "-fparallel"
 647         , "-D__PARALLEL_HASKELL__"
 648         , "-optc-DPAR"
 649         , "-optc-DPAR_TICKY"
 650         , "-package concurrent"
 651         , "-optc-w"
 652         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 653         , "-optl-lpvm3"
 654         , "-optl-lgpvm3"
 655         , "-fvia-C" ]),
 656
 657     (WayPar, Way  "md" "Distributed"
 658         [ "-fparallel"
 659         , "-D__PARALLEL_HASKELL__"
 660         , "-D__DISTRIBUTED_HASKELL__"
 661         , "-optc-DPAR"
 662         , "-optc-DDIST"
 663         , "-package concurrent"
 664         , "-optc-w"
 665         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 666         , "-optl-lpvm3"
 667         , "-optl-lgpvm3"
 668         , "-fvia-C" ]),
 669
 670     (WayGran, Way  "mg" "GranSim"
 671         [ "-fgransim"
 672         , "-D__GRANSIM__"
 673         , "-optc-DGRAN"
 674         , "-package concurrent"
 675         , "-fvia-C" ]),
 676
 677     (WaySMP, Way  "s" "SMP"
 678         [ "-fsmp"
 679         , "-optc-pthread"
 680         , "-optl-pthread"
 681         , "-optc-DSMP"
 682         , "-fvia-C" ]),
 683
 684     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 685     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 686     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 687     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 688     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 689     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 690     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 691     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 692     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 693     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 694     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 695     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 696     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 697     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 698     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 699     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 700     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 701   ]
 702
 703 unregFlags =
 704    [ "-optc-DNO_REGS"
 705    , "-optc-DUSE_MINIINTERPRETER"
 706    , "-fno-asm-mangling"
 707    , "-funregisterised"
 708    , "-fvia-C" ]
 709
 710 -----------------------------------------------------------------------------
 711 -- Options for particular phases
 712
 713 GLOBAL_VAR(v_Opt_dep,    [], [String])
 714 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 715 GLOBAL_VAR(v_Opt_C,      [], [String])
 716 GLOBAL_VAR(v_Opt_l,      [], [String])
 717 GLOBAL_VAR(v_Opt_dll,    [], [String])
 718
 719 getStaticOpts :: IORef [String] -> IO [String]
 720 getStaticOpts ref = readIORef ref >>= return . reverse