ghc/compiler/main/DriverState.hs

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