ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.68 2002/02/12 15:17:15 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   let intersection = filter (`elem` map name old_pkg_details)
 444                                 (map name pkg_details)
 445   if (not (null intersection))
 446         then throwDyn (InstallationError ("package `" ++ head intersection ++ "' is already defined"))
 447         else do
 448   writeIORef v_Package_details (pkg_details ++ old_pkg_details)
 449
 450 addPackage :: String -> IO ()
 451 addPackage package
 452   = do pkg_details <- readIORef v_Package_details
 453        case lookupPkg package pkg_details of
 454           Nothing -> throwDyn (CmdLineError ("unknown package name: " ++ package))
 455           Just details -> do
 456             ps <- readIORef v_Packages
 457             unless (package `elem` ps) $ do
 458                 mapM_ addPackage (package_deps details)
 459                 ps <- readIORef v_Packages
 460                 writeIORef v_Packages (package:ps)
 461
 462 getPackageImportPath   :: IO [String]
 463 getPackageImportPath = do
 464   ps <- getPackageInfo
 465   return (nub (filter (not.null) (concatMap import_dirs ps)))
 466
 467 getPackageIncludePath   :: IO [String]
 468 getPackageIncludePath = do
 469   ps <- getPackageInfo
 470   return (nub (filter (not.null) (concatMap include_dirs ps)))
 471
 472         -- includes are in reverse dependency order (i.e. rts first)
 473 getPackageCIncludes   :: IO [String]
 474 getPackageCIncludes = do
 475   ps <- getPackageInfo
 476   return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
 477
 478 getPackageLibraryPath  :: IO [String]
 479 getPackageLibraryPath = do
 480   ps <- getPackageInfo
 481   return (nub (filter (not.null) (concatMap library_dirs ps)))
 482
 483 getPackageLibraries    :: IO [String]
 484 getPackageLibraries = do
 485   ps <- getPackageInfo
 486   tag <- readIORef v_Build_tag
 487   let suffix = if null tag then "" else '_':tag
 488   return (concat (
 489         map (\p -> map (++suffix) (hACK (hs_libraries p)) ++ extra_libraries p) ps
 490      ))
 491   where
 492      -- This is a totally horrible (temporary) hack, for Win32.  Problem is
 493      -- that package.conf for Win32 says that the main prelude lib is
 494      -- split into HSbase1 and HSbase2, which is needed due to limitations in
 495      -- the PEi386 file format, to make GHCi work.  However, we still only
 496      -- have HSbase.a for static linking, not HSbase1.a and HSbase2.a.
 497      -- getPackageLibraries is called to find the .a's to add to the static
 498      -- link line.  On Win32, this hACK detects HSbase1 and HSbase2 and
 499      -- replaces them with HSbase, so static linking still works.
 500      -- Libraries needed for dynamic (GHCi) linking are discovered via
 501      -- different route (in InteractiveUI.linkPackage).
 502      -- See driver/PackageSrc.hs for the HSbase1/HSbase2 split definition.
 503      -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...)
 504      -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2]
 505      hACK libs
 506 #      ifndef mingw32_TARGET_OS
 507        = libs
 508 #      else
 509        = if   "HSbase1" `elem` libs && "HSbase2" `elem` libs
 510          then "HSbase" : filter ((/= "HSbase").(take 5)) libs
 511          else
 512          if   "HSwin321" `elem` libs && "HSwin322" `elem` libs
 513          then "HSwin32" : filter ((/= "HSwin32").(take 7)) libs
 514          else
 515          libs
 516 #      endif
 517
 518 getPackageExtraGhcOpts :: IO [String]
 519 getPackageExtraGhcOpts = do
 520   ps <- getPackageInfo
 521   return (concatMap extra_ghc_opts ps)
 522
 523 getPackageExtraCcOpts  :: IO [String]
 524 getPackageExtraCcOpts = do
 525   ps <- getPackageInfo
 526   return (concatMap extra_cc_opts ps)
 527
 528 getPackageExtraLdOpts  :: IO [String]
 529 getPackageExtraLdOpts = do
 530   ps <- getPackageInfo
 531   return (concatMap extra_ld_opts ps)
 532
 533 getPackageInfo :: IO [PackageConfig]
 534 getPackageInfo = do
 535   ps <- readIORef v_Packages
 536   getPackageDetails ps
 537
 538 getPackageDetails :: [String] -> IO [PackageConfig]
 539 getPackageDetails ps = do
 540   pkg_details <- readIORef v_Package_details
 541   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 542
 543 GLOBAL_VAR(v_Package_details, [], [PackageConfig])
 544
 545 lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig
 546 lookupPkg nm ps
 547    = case [p | p <- ps, name p == nm] of
 548         []    -> Nothing
 549         (p:_) -> Just p
 550
 551 -----------------------------------------------------------------------------
 552 -- Ways
 553
 554 -- The central concept of a "way" is that all objects in a given
 555 -- program must be compiled in the same "way".  Certain options change
 556 -- parameters of the virtual machine, eg. profiling adds an extra word
 557 -- to the object header, so profiling objects cannot be linked with
 558 -- non-profiling objects.
 559
 560 -- After parsing the command-line options, we determine which "way" we
 561 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 562
 563 -- We then find the "build-tag" associated with this way, and this
 564 -- becomes the suffix used to find .hi files and libraries used in
 565 -- this compilation.
 566
 567 GLOBAL_VAR(v_Build_tag, "", String)
 568
 569 data WayName
 570   = WayProf
 571   | WayUnreg
 572   | WayTicky
 573   | WayPar
 574   | WayGran
 575   | WaySMP
 576   | WayNDP
 577   | WayDebug
 578   | WayUser_a
 579   | WayUser_b
 580   | WayUser_c
 581   | WayUser_d
 582   | WayUser_e
 583   | WayUser_f
 584   | WayUser_g
 585   | WayUser_h
 586   | WayUser_i
 587   | WayUser_j
 588   | WayUser_k
 589   | WayUser_l
 590   | WayUser_m
 591   | WayUser_n
 592   | WayUser_o
 593   | WayUser_A
 594   | WayUser_B
 595   deriving (Eq,Ord)
 596
 597 GLOBAL_VAR(v_Ways, [] ,[WayName])
 598
 599 allowed_combination way = way `elem` combs
 600   where  -- the sub-lists must be ordered according to WayName,
 601          -- because findBuildTag sorts them
 602     combs                = [ [WayProf, WayUnreg],
 603                              [WayProf, WaySMP]  ,
 604                              [WayProf, WayNDP]  ]
 605
 606 findBuildTag :: IO [String]  -- new options
 607 findBuildTag = do
 608   way_names <- readIORef v_Ways
 609   case sort way_names of
 610      []  -> do  -- writeIORef v_Build_tag ""
 611                 return []
 612
 613      [w] -> do let details = lkupWay w
 614                writeIORef v_Build_tag (wayTag details)
 615                return (wayOpts details)
 616
 617      ws  -> if not (allowed_combination ws)
 618                 then throwDyn (CmdLineError $
 619                                 "combination not supported: "  ++
 620                                 foldr1 (\a b -> a ++ '/':b)
 621                                 (map (wayName . lkupWay) ws))
 622                 else let stuff = map lkupWay ws
 623                          tag   = concat (map wayTag stuff)
 624                          flags = map wayOpts stuff
 625                      in do
 626                      writeIORef v_Build_tag tag
 627                      return (concat flags)
 628
 629 lkupWay w =
 630    case lookup w way_details of
 631         Nothing -> error "findBuildTag"
 632         Just details -> details
 633
 634 data Way = Way {
 635   wayTag   :: String,
 636   wayName  :: String,
 637   wayOpts  :: [String]
 638   }
 639
 640 way_details :: [ (WayName, Way) ]
 641 way_details =
 642   [ (WayProf, Way  "p" "Profiling"
 643         [ "-fscc-profiling"
 644         , "-DPROFILING"
 645         , "-optc-DPROFILING"
 646         , "-fvia-C" ]),
 647
 648     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 649         [ "-fticky-ticky"
 650         , "-DTICKY_TICKY"
 651         , "-optc-DTICKY_TICKY"
 652         , "-fvia-C" ]),
 653
 654     (WayUnreg, Way  "u" "Unregisterised"
 655         unregFlags ),
 656
 657     -- optl's below to tell linker where to find the PVM library -- HWL
 658     (WayPar, Way  "mp" "Parallel"
 659         [ "-fparallel"
 660         , "-D__PARALLEL_HASKELL__"
 661         , "-optc-DPAR"
 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     -- at the moment we only change the RTS and could share compiler and libs!
 670     (WayPar, Way  "mt" "Parallel ticky profiling"
 671         [ "-fparallel"
 672         , "-D__PARALLEL_HASKELL__"
 673         , "-optc-DPAR"
 674         , "-optc-DPAR_TICKY"
 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     (WayPar, Way  "md" "Distributed"
 683         [ "-fparallel"
 684         , "-D__PARALLEL_HASKELL__"
 685         , "-D__DISTRIBUTED_HASKELL__"
 686         , "-optc-DPAR"
 687         , "-optc-DDIST"
 688         , "-package concurrent"
 689         , "-optc-w"
 690         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 691         , "-optl-lpvm3"
 692         , "-optl-lgpvm3"
 693         , "-fvia-C" ]),
 694
 695     (WayGran, Way  "mg" "GranSim"
 696         [ "-fgransim"
 697         , "-D__GRANSIM__"
 698         , "-optc-DGRAN"
 699         , "-package concurrent"
 700         , "-fvia-C" ]),
 701
 702     (WaySMP, Way  "s" "SMP"
 703         [ "-fsmp"
 704         , "-optc-pthread"
 705         , "-optl-pthread"
 706         , "-optc-DSMP"
 707         , "-fvia-C" ]),
 708
 709     (WayNDP, Way  "ndp" "Nested data parallelism"
 710         [ "-fparr"
 711         , "-fflatten"]),
 712
 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     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 716     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 717     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 718     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 719     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 720     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 721     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 722     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 723     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 724     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 725     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 726     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 727     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 728     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 729     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 730   ]
 731
 732 unregFlags =
 733    [ "-optc-DNO_REGS"
 734    , "-optc-DUSE_MINIINTERPRETER"
 735    , "-fno-asm-mangling"
 736    , "-funregisterised"
 737    , "-fvia-C" ]
 738
 739 -----------------------------------------------------------------------------
 740 -- Options for particular phases
 741
 742 GLOBAL_VAR(v_Opt_dep,    [], [String])
 743 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 744 GLOBAL_VAR(v_Opt_C,      [], [String])
 745 GLOBAL_VAR(v_Opt_l,      [], [String])
 746 GLOBAL_VAR(v_Opt_dll,    [], [String])
 747
 748 getStaticOpts :: IORef [String] -> IO [String]
 749 getStaticOpts ref = readIORef ref >>= return . reverse