ghc/compiler/main/DriverState.hs

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