ghc/compiler/main/DriverState.hs

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