ghc/compiler/main/DriverState.hs

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