ghc/compiler/main/DriverState.hs

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