ghc/compiler/main/DriverState.hs

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