ghc/compiler/main/DriverState.hs

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