ghc/compiler/main/DriverState.hs

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