ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.71 2002/03/13 13:51:35 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 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 DEBUG
 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 DEBUG
 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 DEBUG
 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      hACK libs
 501 #      ifndef mingw32_TARGET_OS
 502        = libs
 503 #      else
 504        = if   "HSbase1" `elem` libs && "HSbase2" `elem` libs
 505          then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs
 506          else
 507          if   "HSwin321" `elem` libs && "HSwin322" `elem` libs
 508          then "HSwin32" : filter (not.(isPrefixOf "HSwin32")) libs
 509          else
 510          libs
 511 #      endif
 512
 513 getPackageExtraGhcOpts :: IO [String]
 514 getPackageExtraGhcOpts = do
 515   ps <- getPackageInfo
 516   return (concatMap extra_ghc_opts ps)
 517
 518 getPackageExtraCcOpts  :: IO [String]
 519 getPackageExtraCcOpts = do
 520   ps <- getPackageInfo
 521   return (concatMap extra_cc_opts ps)
 522
 523 getPackageExtraLdOpts  :: IO [String]
 524 getPackageExtraLdOpts = do
 525   ps <- getPackageInfo
 526   return (concatMap extra_ld_opts ps)
 527
 528 getPackageInfo :: IO [PackageConfig]
 529 getPackageInfo = do
 530   ps <- readIORef v_Packages
 531   getPackageDetails ps
 532
 533 getPackageDetails :: [String] -> IO [PackageConfig]
 534 getPackageDetails ps = do
 535   pkg_details <- readIORef v_Package_details
 536   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 537
 538 GLOBAL_VAR(v_Package_details, [], [PackageConfig])
 539
 540 lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig
 541 lookupPkg nm ps
 542    = case [p | p <- ps, name p == nm] of
 543         []    -> Nothing
 544         (p:_) -> Just p
 545
 546 -----------------------------------------------------------------------------
 547 -- Ways
 548
 549 -- The central concept of a "way" is that all objects in a given
 550 -- program must be compiled in the same "way".  Certain options change
 551 -- parameters of the virtual machine, eg. profiling adds an extra word
 552 -- to the object header, so profiling objects cannot be linked with
 553 -- non-profiling objects.
 554
 555 -- After parsing the command-line options, we determine which "way" we
 556 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 557
 558 -- We then find the "build-tag" associated with this way, and this
 559 -- becomes the suffix used to find .hi files and libraries used in
 560 -- this compilation.
 561
 562 GLOBAL_VAR(v_Build_tag, "", String)
 563
 564 data WayName
 565   = WayProf
 566   | WayUnreg
 567   | WayTicky
 568   | WayPar
 569   | WayGran
 570   | WaySMP
 571   | WayNDP
 572   | WayDebug
 573   | WayUser_a
 574   | WayUser_b
 575   | WayUser_c
 576   | WayUser_d
 577   | WayUser_e
 578   | WayUser_f
 579   | WayUser_g
 580   | WayUser_h
 581   | WayUser_i
 582   | WayUser_j
 583   | WayUser_k
 584   | WayUser_l
 585   | WayUser_m
 586   | WayUser_n
 587   | WayUser_o
 588   | WayUser_A
 589   | WayUser_B
 590   deriving (Eq,Ord)
 591
 592 GLOBAL_VAR(v_Ways, [] ,[WayName])
 593
 594 allowed_combination way = way `elem` combs
 595   where  -- the sub-lists must be ordered according to WayName,
 596          -- because findBuildTag sorts them
 597     combs                = [ [WayProf, WayUnreg],
 598                              [WayProf, WaySMP]  ,
 599                              [WayProf, WayNDP]  ]
 600
 601 findBuildTag :: IO [String]  -- new options
 602 findBuildTag = do
 603   way_names <- readIORef v_Ways
 604   case sort way_names of
 605      []  -> do  -- writeIORef v_Build_tag ""
 606                 return []
 607
 608      [w] -> do let details = lkupWay w
 609                writeIORef v_Build_tag (wayTag details)
 610                return (wayOpts details)
 611
 612      ws  -> if not (allowed_combination ws)
 613                 then throwDyn (CmdLineError $
 614                                 "combination not supported: "  ++
 615                                 foldr1 (\a b -> a ++ '/':b)
 616                                 (map (wayName . lkupWay) ws))
 617                 else let stuff = map lkupWay ws
 618                          tag   = concat (map wayTag stuff)
 619                          flags = map wayOpts stuff
 620                      in do
 621                      writeIORef v_Build_tag tag
 622                      return (concat flags)
 623
 624 lkupWay w =
 625    case lookup w way_details of
 626         Nothing -> error "findBuildTag"
 627         Just details -> details
 628
 629 data Way = Way {
 630   wayTag   :: String,
 631   wayName  :: String,
 632   wayOpts  :: [String]
 633   }
 634
 635 way_details :: [ (WayName, Way) ]
 636 way_details =
 637   [ (WayProf, Way  "p" "Profiling"
 638         [ "-fscc-profiling"
 639         , "-DPROFILING"
 640         , "-optc-DPROFILING"
 641         , "-fvia-C" ]),
 642
 643     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 644         [ "-fticky-ticky"
 645         , "-DTICKY_TICKY"
 646         , "-optc-DTICKY_TICKY"
 647         , "-fvia-C" ]),
 648
 649     (WayUnreg, Way  "u" "Unregisterised"
 650         unregFlags ),
 651
 652     -- optl's below to tell linker where to find the PVM library -- HWL
 653     (WayPar, Way  "mp" "Parallel"
 654         [ "-fparallel"
 655         , "-D__PARALLEL_HASKELL__"
 656         , "-optc-DPAR"
 657         , "-package concurrent"
 658         , "-optc-w"
 659         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 660         , "-optl-lpvm3"
 661         , "-optl-lgpvm3"
 662         , "-fvia-C" ]),
 663
 664     -- at the moment we only change the RTS and could share compiler and libs!
 665     (WayPar, Way  "mt" "Parallel ticky profiling"
 666         [ "-fparallel"
 667         , "-D__PARALLEL_HASKELL__"
 668         , "-optc-DPAR"
 669         , "-optc-DPAR_TICKY"
 670         , "-package concurrent"
 671         , "-optc-w"
 672         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 673         , "-optl-lpvm3"
 674         , "-optl-lgpvm3"
 675         , "-fvia-C" ]),
 676
 677     (WayPar, Way  "md" "Distributed"
 678         [ "-fparallel"
 679         , "-D__PARALLEL_HASKELL__"
 680         , "-D__DISTRIBUTED_HASKELL__"
 681         , "-optc-DPAR"
 682         , "-optc-DDIST"
 683         , "-package concurrent"
 684         , "-optc-w"
 685         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 686         , "-optl-lpvm3"
 687         , "-optl-lgpvm3"
 688         , "-fvia-C" ]),
 689
 690     (WayGran, Way  "mg" "GranSim"
 691         [ "-fgransim"
 692         , "-D__GRANSIM__"
 693         , "-optc-DGRAN"
 694         , "-package concurrent"
 695         , "-fvia-C" ]),
 696
 697     (WaySMP, Way  "s" "SMP"
 698         [ "-fsmp"
 699         , "-optc-pthread"
 700         , "-optl-pthread"
 701         , "-optc-DSMP"
 702         , "-fvia-C" ]),
 703
 704     (WayNDP, Way  "ndp" "Nested data parallelism"
 705         [ "-fparr"
 706         , "-fflatten"]),
 707
 708     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 709     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 710     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 711     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 712     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 713     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 714     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 715     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 716     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 717     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 718     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 719     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 720     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 721     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 722     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 723     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 724     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 725   ]
 726
 727 unregFlags =
 728    [ "-optc-DNO_REGS"
 729    , "-optc-DUSE_MINIINTERPRETER"
 730    , "-fno-asm-mangling"
 731    , "-funregisterised"
 732    , "-fvia-C" ]
 733
 734 -----------------------------------------------------------------------------
 735 -- Options for particular phases
 736
 737 GLOBAL_VAR(v_Opt_dep,    [], [String])
 738 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 739 GLOBAL_VAR(v_Opt_C,      [], [String])
 740 GLOBAL_VAR(v_Opt_l,      [], [String])
 741 GLOBAL_VAR(v_Opt_dll,    [], [String])
 742
 743 getStaticOpts :: IORef [String] -> IO [String]
 744 getStaticOpts ref = readIORef ref >>= return . reverse