ghc/compiler/main/DriverState.hs

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