ghc/compiler/main/DriverState.hs

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