ghc/compiler/main/DriverState.hs

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