ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.65 2001/12/15 12:03:08 panne 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 #ifdef DEBUG
 283         if cpr        then CoreDoCPResult   else CoreDoNothing,
 284 #endif
 285         if strictness then CoreDoStrictness else CoreDoNothing,
 286         CoreDoWorkerWrapper,
 287         CoreDoGlomBinds,
 288
 289         CoreDoSimplify (SimplPhase 0) [
 290            MaxSimplifierIterations max_iter
 291         ],
 292
 293         CoreDoFloatOutwards (FloatOutSw False   -- Not lambdas
 294                                         True),  -- Float constants
 295                 -- nofib/spectral/hartel/wang doubles in speed if you
 296                 -- do full laziness late in the day.  It only happens
 297                 -- after fusion and other stuff, so the early pass doesn't
 298                 -- catch it.  For the record, the redex is
 299                 --        f_el22 (f_el21 r_midblock)
 300
 301
 302         -- We want CSE to follow the final full-laziness pass, because it may
 303         -- succeed in commoning up things floated out by full laziness.
 304         -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
 305
 306         if cse then CoreCSE else CoreDoNothing,
 307
 308         CoreDoFloatInwards,
 309
 310 -- Case-liberation for -O2.  This should be after
 311 -- strictness analysis and the simplification which follows it.
 312
 313         case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
 314
 315         if opt_level >= 2 then
 316            CoreLiberateCase
 317         else
 318            CoreDoNothing,
 319         if opt_level >= 2 then
 320            CoreDoSpecConstr
 321         else
 322            CoreDoNothing,
 323
 324         -- Final clean-up simplification:
 325         CoreDoSimplify (SimplPhase 0) [
 326           MaxSimplifierIterations max_iter
 327         ]
 328      ]
 329
 330 buildStgToDo :: IO [ StgToDo ]
 331 buildStgToDo = do
 332   stg_stats <- readIORef v_StgStats
 333   let flags1 | stg_stats = [ D_stg_stats ]
 334              | otherwise = [ ]
 335
 336         -- STG passes
 337   ways_ <- readIORef v_Ways
 338   let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
 339              | otherwise            = flags1
 340
 341   return flags2
 342
 343 -----------------------------------------------------------------------------
 344 -- Paths & Libraries
 345
 346 split_marker = ':'   -- not configurable (ToDo)
 347
 348 v_Import_paths, v_Include_paths, v_Library_paths :: IORef [String]
 349 GLOBAL_VAR(v_Import_paths,  ["."], [String])
 350 GLOBAL_VAR(v_Include_paths, ["."], [String])
 351 GLOBAL_VAR(v_Library_paths, [],  [String])
 352
 353 GLOBAL_VAR(v_Cmdline_libraries,   [], [String])
 354
 355 addToDirList :: IORef [String] -> String -> IO ()
 356 addToDirList ref path
 357   = do paths           <- readIORef ref
 358        shiny_new_ones  <- splitUp path
 359        writeIORef ref (paths ++ filter (not.null) shiny_new_ones)
 360                 -- empty paths are ignored: there might be a trailing
 361                 -- ':' in the initial list, for example.  Empty paths can
 362                 -- cause confusion when they are translated into -I options
 363                 -- for passing to gcc.
 364   where
 365     splitUp ::String -> IO [String]
 366 #ifdef mingw32_TARGET_OS
 367      -- 'hybrid' support for DOS-style paths in directory lists.
 368      --
 369      -- That is, if "foo:bar:baz" is used, this interpreted as
 370      -- consisting of three entries, 'foo', 'bar', 'baz'.
 371      -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted
 372      -- as four elts, "c:/foo", "c:\\foo", "x", and "/bar" --
 373      -- *provided* c:/foo exists and x:/bar doesn't.
 374      --
 375      -- Notice that no attempt is made to fully replace the 'standard'
 376      -- split marker ':' with the Windows / DOS one, ';'. The reason being
 377      -- that this will cause too much breakage for users & ':' will
 378      -- work fine even with DOS paths, if you're not insisting on being silly.
 379      -- So, use either.
 380     splitUp []         = return []
 381     splitUp (x:':':div:xs)
 382       | div `elem` dir_markers = do
 383           let (p,rs) = findNextPath xs
 384           ps  <- splitUp rs
 385            {-
 386              Consult the file system to check the interpretation
 387              of (x:':':div:p) -- this is arguably excessive, we
 388              could skip this test & just say that it is a valid
 389              dir path.
 390            -}
 391           flg <- doesDirectoryExist (x:':':div:p)
 392           if flg then
 393              return ((x:':':div:p):ps)
 394            else
 395              return ([x]:(div:p):ps)
 396     splitUp xs = do
 397       let (p,rs) = findNextPath xs
 398       ps <- splitUp rs
 399       return (cons p ps)
 400
 401     cons "" xs = xs
 402     cons x  xs = x:xs
 403
 404     -- will be called either when we've consumed nought or the "<Drive>:/" part of
 405     -- a DOS path, so splitting is just a Q of finding the next split marker.
 406     findNextPath xs =
 407         case break (`elem` split_markers) xs of
 408            (p, d:ds) -> (p, ds)
 409            (p, xs)   -> (p, xs)
 410
 411     split_markers :: [Char]
 412     split_markers = [':', ';']
 413
 414     dir_markers :: [Char]
 415     dir_markers = ['/', '\\']
 416
 417 #else
 418     splitUp xs = return (split split_marker xs)
 419 #endif
 420
 421 GLOBAL_VAR(v_HCHeader, "", String)
 422
 423 -----------------------------------------------------------------------------
 424 -- Packages
 425
 426 -- package list is maintained in dependency order
 427 GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String])
 428
 429 readPackageConf :: String -> IO ()
 430 readPackageConf conf_file = do
 431   proto_pkg_details <- loadPackageConfig conf_file
 432   top_dir <- getTopDir
 433   let pkg_details    = mungePackagePaths top_dir proto_pkg_details
 434   old_pkg_details <- readIORef v_Package_details
 435   let intersection = filter (`elem` map name old_pkg_details)
 436                                 (map name pkg_details)
 437   if (not (null intersection))
 438         then throwDyn (InstallationError ("package `" ++ head intersection ++ "' is already defined"))
 439         else do
 440   writeIORef v_Package_details (pkg_details ++ old_pkg_details)
 441
 442 addPackage :: String -> IO ()
 443 addPackage package
 444   = do pkg_details <- readIORef v_Package_details
 445        case lookupPkg package pkg_details of
 446           Nothing -> throwDyn (CmdLineError ("unknown package name: " ++ package))
 447           Just details -> do
 448             ps <- readIORef v_Packages
 449             unless (package `elem` ps) $ do
 450                 mapM_ addPackage (package_deps details)
 451                 ps <- readIORef v_Packages
 452                 writeIORef v_Packages (package:ps)
 453
 454 getPackageImportPath   :: IO [String]
 455 getPackageImportPath = do
 456   ps <- getPackageInfo
 457   return (nub (filter (not.null) (concatMap import_dirs ps)))
 458
 459 getPackageIncludePath   :: IO [String]
 460 getPackageIncludePath = do
 461   ps <- getPackageInfo
 462   return (nub (filter (not.null) (concatMap include_dirs ps)))
 463
 464         -- includes are in reverse dependency order (i.e. rts first)
 465 getPackageCIncludes   :: IO [String]
 466 getPackageCIncludes = do
 467   ps <- getPackageInfo
 468   return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
 469
 470 getPackageLibraryPath  :: IO [String]
 471 getPackageLibraryPath = do
 472   ps <- getPackageInfo
 473   return (nub (filter (not.null) (concatMap library_dirs ps)))
 474
 475 getPackageLibraries    :: IO [String]
 476 getPackageLibraries = do
 477   ps <- getPackageInfo
 478   tag <- readIORef v_Build_tag
 479   let suffix = if null tag then "" else '_':tag
 480   return (concat (
 481         map (\p -> map (++suffix) (hACK (hs_libraries p)) ++ extra_libraries p) ps
 482      ))
 483   where
 484      -- This is a totally horrible (temporary) hack, for Win32.  Problem is
 485      -- that package.conf for Win32 says that the main prelude lib is
 486      -- split into HSstd1 and HSstd2, which is needed due to limitations in
 487      -- the PEi386 file format, to make GHCi work.  However, we still only
 488      -- have HSstd.a for static linking, not HSstd1.a and HSstd2.a.
 489      -- getPackageLibraries is called to find the .a's to add to the static
 490      -- link line.  On Win32, this hACK detects HSstd1 and HSstd2 and
 491      -- replaces them with HSstd, so static linking still works.
 492      -- Libraries needed for dynamic (GHCi) linking are discovered via
 493      -- different route (in InteractiveUI.linkPackage).
 494      -- See driver/PackageSrc.hs for the HSstd1/HSstd2 split definition.
 495      -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...)
 496      -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2]
 497      hACK libs
 498 #      ifndef mingw32_TARGET_OS
 499        = libs
 500 #      else
 501        = if   "HSstd1" `elem` libs && "HSstd2" `elem` libs
 502          then "HSstd" : filter ((/= "HSstd").(take 5)) libs
 503          else
 504          if   "HSwin321" `elem` libs && "HSwin322" `elem` libs
 505          then "HSwin32" : filter ((/= "HSwin32").(take 7)) libs
 506          else
 507          libs
 508 #      endif
 509
 510 getPackageExtraGhcOpts :: IO [String]
 511 getPackageExtraGhcOpts = do
 512   ps <- getPackageInfo
 513   return (concatMap extra_ghc_opts ps)
 514
 515 getPackageExtraCcOpts  :: IO [String]
 516 getPackageExtraCcOpts = do
 517   ps <- getPackageInfo
 518   return (concatMap extra_cc_opts ps)
 519
 520 getPackageExtraLdOpts  :: IO [String]
 521 getPackageExtraLdOpts = do
 522   ps <- getPackageInfo
 523   return (concatMap extra_ld_opts ps)
 524
 525 getPackageInfo :: IO [PackageConfig]
 526 getPackageInfo = do
 527   ps <- readIORef v_Packages
 528   getPackageDetails ps
 529
 530 getPackageDetails :: [String] -> IO [PackageConfig]
 531 getPackageDetails ps = do
 532   pkg_details <- readIORef v_Package_details
 533   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 534
 535 GLOBAL_VAR(v_Package_details, [], [PackageConfig])
 536
 537 lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig
 538 lookupPkg nm ps
 539    = case [p | p <- ps, name p == nm] of
 540         []    -> Nothing
 541         (p:_) -> Just p
 542
 543 -----------------------------------------------------------------------------
 544 -- Ways
 545
 546 -- The central concept of a "way" is that all objects in a given
 547 -- program must be compiled in the same "way".  Certain options change
 548 -- parameters of the virtual machine, eg. profiling adds an extra word
 549 -- to the object header, so profiling objects cannot be linked with
 550 -- non-profiling objects.
 551
 552 -- After parsing the command-line options, we determine which "way" we
 553 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 554
 555 -- We then find the "build-tag" associated with this way, and this
 556 -- becomes the suffix used to find .hi files and libraries used in
 557 -- this compilation.
 558
 559 GLOBAL_VAR(v_Build_tag, "", String)
 560
 561 data WayName
 562   = WayProf
 563   | WayUnreg
 564   | WayTicky
 565   | WayPar
 566   | WayGran
 567   | WaySMP
 568   | WayDebug
 569   | WayUser_a
 570   | WayUser_b
 571   | WayUser_c
 572   | WayUser_d
 573   | WayUser_e
 574   | WayUser_f
 575   | WayUser_g
 576   | WayUser_h
 577   | WayUser_i
 578   | WayUser_j
 579   | WayUser_k
 580   | WayUser_l
 581   | WayUser_m
 582   | WayUser_n
 583   | WayUser_o
 584   | WayUser_A
 585   | WayUser_B
 586   deriving (Eq,Ord)
 587
 588 GLOBAL_VAR(v_Ways, [] ,[WayName])
 589
 590 allowed_combination way = way `elem` combs
 591   where  -- the sub-lists must be ordered according to WayName,
 592          -- because findBuildTag sorts them
 593     combs                = [ [WayProf,WayUnreg], [WayProf,WaySMP] ]
 594
 595 findBuildTag :: IO [String]  -- new options
 596 findBuildTag = do
 597   way_names <- readIORef v_Ways
 598   case sort way_names of
 599      []  -> do  -- writeIORef v_Build_tag ""
 600                 return []
 601
 602      [w] -> do let details = lkupWay w
 603                writeIORef v_Build_tag (wayTag details)
 604                return (wayOpts details)
 605
 606      ws  -> if not (allowed_combination ws)
 607                 then throwDyn (CmdLineError $
 608                                 "combination not supported: "  ++
 609                                 foldr1 (\a b -> a ++ '/':b)
 610                                 (map (wayName . lkupWay) ws))
 611                 else let stuff = map lkupWay ws
 612                          tag   = concat (map wayTag stuff)
 613                          flags = map wayOpts stuff
 614                      in do
 615                      writeIORef v_Build_tag tag
 616                      return (concat flags)
 617
 618 lkupWay w =
 619    case lookup w way_details of
 620         Nothing -> error "findBuildTag"
 621         Just details -> details
 622
 623 data Way = Way {
 624   wayTag   :: String,
 625   wayName  :: String,
 626   wayOpts  :: [String]
 627   }
 628
 629 way_details :: [ (WayName, Way) ]
 630 way_details =
 631   [ (WayProf, Way  "p" "Profiling"
 632         [ "-fscc-profiling"
 633         , "-DPROFILING"
 634         , "-optc-DPROFILING"
 635         , "-fvia-C" ]),
 636
 637     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 638         [ "-fticky-ticky"
 639         , "-DTICKY_TICKY"
 640         , "-optc-DTICKY_TICKY"
 641         , "-fvia-C" ]),
 642
 643     (WayUnreg, Way  "u" "Unregisterised"
 644         unregFlags ),
 645
 646     -- optl's below to tell linker where to find the PVM library -- HWL
 647     (WayPar, Way  "mp" "Parallel"
 648         [ "-fparallel"
 649         , "-D__PARALLEL_HASKELL__"
 650         , "-optc-DPAR"
 651         , "-package concurrent"
 652         , "-optc-w"
 653         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 654         , "-optl-lpvm3"
 655         , "-optl-lgpvm3"
 656         , "-fvia-C" ]),
 657
 658     -- at the moment we only change the RTS and could share compiler and libs!
 659     (WayPar, Way  "mt" "Parallel ticky profiling"
 660         [ "-fparallel"
 661         , "-D__PARALLEL_HASKELL__"
 662         , "-optc-DPAR"
 663         , "-optc-DPAR_TICKY"
 664         , "-package concurrent"
 665         , "-optc-w"
 666         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 667         , "-optl-lpvm3"
 668         , "-optl-lgpvm3"
 669         , "-fvia-C" ]),
 670
 671     (WayPar, Way  "md" "Distributed"
 672         [ "-fparallel"
 673         , "-D__PARALLEL_HASKELL__"
 674         , "-D__DISTRIBUTED_HASKELL__"
 675         , "-optc-DPAR"
 676         , "-optc-DDIST"
 677         , "-package concurrent"
 678         , "-optc-w"
 679         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 680         , "-optl-lpvm3"
 681         , "-optl-lgpvm3"
 682         , "-fvia-C" ]),
 683
 684     (WayGran, Way  "mg" "GranSim"
 685         [ "-fgransim"
 686         , "-D__GRANSIM__"
 687         , "-optc-DGRAN"
 688         , "-package concurrent"
 689         , "-fvia-C" ]),
 690
 691     (WaySMP, Way  "s" "SMP"
 692         [ "-fsmp"
 693         , "-optc-pthread"
 694         , "-optl-pthread"
 695         , "-optc-DSMP"
 696         , "-fvia-C" ]),
 697
 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     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 701     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 702     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 703     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 704     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 705     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 706     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 707     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 708     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 709     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 710     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 711     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 712     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 713     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 714     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 715   ]
 716
 717 unregFlags =
 718    [ "-optc-DNO_REGS"
 719    , "-optc-DUSE_MINIINTERPRETER"
 720    , "-fno-asm-mangling"
 721    , "-funregisterised"
 722    , "-fvia-C" ]
 723
 724 -----------------------------------------------------------------------------
 725 -- Options for particular phases
 726
 727 GLOBAL_VAR(v_Opt_dep,    [], [String])
 728 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 729 GLOBAL_VAR(v_Opt_C,      [], [String])
 730 GLOBAL_VAR(v_Opt_l,      [], [String])
 731 GLOBAL_VAR(v_Opt_dll,    [], [String])
 732
 733 getStaticOpts :: IORef [String] -> IO [String]
 734 getStaticOpts ref = readIORef ref >>= return . reverse