ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.81 2002/08/29 15:44:15 simonmar Exp $
   3 --
   4 -- Settings for the driver
   5 --
   6 -- (c) The University of Glasgow 2002
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverState where
  11
  12 #include "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import SysTools         ( getTopDir )
  16 import ParsePkgConf     ( loadPackageConfig )
  17 import Packages         ( PackageConfig(..), mungePackagePaths )
  18 import CmdLineOpts
  19 import DriverPhases
  20 import DriverUtil
  21 import Util
  22 import Config
  23 import Panic
  24
  25 import DATA_IOREF       ( IORef, newIORef, readIORef, writeIORef )
  26 import EXCEPTION
  27
  28 import List
  29 import Char
  30 import Monad
  31 import Maybe     ( fromJust, isJust )
  32 import Directory ( doesDirectoryExist )
  33
  34 -----------------------------------------------------------------------------
  35 -- non-configured things
  36
  37 cHaskell1Version = "5" -- i.e., Haskell 98
  38
  39 -----------------------------------------------------------------------------
  40 -- GHC modes of operation
  41
  42 data GhcMode
  43   = DoMkDependHS                        -- ghc -M
  44   | DoMkDLL                             -- ghc --mk-dll
  45   | StopBefore Phase                    -- ghc -E | -C | -S | -c
  46   | DoMake                              -- ghc --make
  47   | DoInteractive                       -- ghc --interactive
  48   | DoLink                              -- [ the default ]
  49   deriving (Eq,Show)
  50
  51 GLOBAL_VAR(v_GhcMode,     DoLink, GhcMode)
  52 GLOBAL_VAR(v_GhcModeFlag, "",     String)
  53
  54 setMode :: GhcMode -> String -> IO ()
  55 setMode m flag = do
  56   old_mode <- readIORef v_GhcMode
  57   old_flag <- readIORef v_GhcModeFlag
  58   when (notNull old_flag && flag /= old_flag) $
  59       throwDyn (UsageError
  60           ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
  61   writeIORef v_GhcMode m
  62   writeIORef v_GhcModeFlag flag
  63
  64 isCompManagerMode DoMake        = True
  65 isCompManagerMode DoInteractive = True
  66 isCompManagerMode _             = False
  67
  68 -----------------------------------------------------------------------------
  69 -- Global compilation flags
  70
  71 -- Cpp-related flags
  72 v_Hs_source_cpp_opts = global
  73         [ "-D__HASKELL1__="++cHaskell1Version
  74         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
  75         , "-D__HASKELL98__"
  76         , "-D__CONCURRENT_HASKELL__"
  77         ]
  78 {-# NOINLINE v_Hs_source_cpp_opts #-}
  79
  80
  81 -- Keep output from intermediate phases
  82 GLOBAL_VAR(v_Keep_hi_diffs,             False,          Bool)
  83 GLOBAL_VAR(v_Keep_hc_files,             False,          Bool)
  84 GLOBAL_VAR(v_Keep_s_files,              False,          Bool)
  85 GLOBAL_VAR(v_Keep_raw_s_files,          False,          Bool)
  86 GLOBAL_VAR(v_Keep_tmp_files,            False,          Bool)
  87 #ifdef ILX
  88 GLOBAL_VAR(v_Keep_il_files,             False,          Bool)
  89 GLOBAL_VAR(v_Keep_ilx_files,            False,          Bool)
  90 #endif
  91
  92 -- Misc
  93 GLOBAL_VAR(v_Scale_sizes_by,            1.0,            Double)
  94 GLOBAL_VAR(v_Static,                    True,           Bool)
  95 GLOBAL_VAR(v_NoHsMain,                  False,          Bool)
  96 GLOBAL_VAR(v_Recomp,                    True,           Bool)
  97 GLOBAL_VAR(v_Collect_ghc_timing,        False,          Bool)
  98 GLOBAL_VAR(v_Do_asm_mangling,           True,           Bool)
  99 GLOBAL_VAR(v_Excess_precision,          False,          Bool)
 100 GLOBAL_VAR(v_Read_DotGHCi,              True,           Bool)
 101
 102 -- Preprocessor flags
 103 GLOBAL_VAR(v_Hs_source_pp_opts, [], [String])
 104
 105 -----------------------------------------------------------------------------
 106 -- Splitting object files (for libraries)
 107
 108 GLOBAL_VAR(v_Split_object_files,        False,          Bool)
 109 GLOBAL_VAR(v_Split_info,                ("",0),         (String,Int))
 110         -- The split prefix and number of files
 111
 112
 113 can_split :: Bool
 114 can_split =  prefixMatch "i386"    cTARGETPLATFORM
 115           || prefixMatch "alpha"   cTARGETPLATFORM
 116           || prefixMatch "hppa"    cTARGETPLATFORM
 117           || prefixMatch "m68k"    cTARGETPLATFORM
 118           || prefixMatch "mips"    cTARGETPLATFORM
 119           || prefixMatch "powerpc" cTARGETPLATFORM
 120           || prefixMatch "rs6000"  cTARGETPLATFORM
 121           || prefixMatch "sparc"   cTARGETPLATFORM
 122
 123 -----------------------------------------------------------------------------
 124 -- Compiler output options
 125
 126 GLOBAL_VAR(v_Output_dir,  Nothing, Maybe String)
 127 GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
 128 GLOBAL_VAR(v_Output_hi,   Nothing, Maybe String)
 129
 130 -- called to verify that the output files & directories
 131 -- point somewhere valid.
 132 --
 133 -- The assumption is that the directory portion of these output
 134 -- options will have to exist by the time 'verifyOutputFiles'
 135 -- is invoked.
 136 --
 137 verifyOutputFiles :: IO ()
 138 verifyOutputFiles = do
 139   odir <- readIORef v_Output_dir
 140   when (isJust odir) $ do
 141      let dir = fromJust odir
 142      flg <- doesDirectoryExist dir
 143      when (not flg) (nonExistentDir "-odir" dir)
 144   ofile <- readIORef v_Output_file
 145   when (isJust ofile) $ do
 146      let fn = fromJust ofile
 147      flg <- doesDirNameExist fn
 148      when (not flg) (nonExistentDir "-o" fn)
 149   ohi <- readIORef v_Output_hi
 150   when (isJust ohi) $ do
 151      let hi = fromJust ohi
 152      flg <- doesDirNameExist hi
 153      when (not flg) (nonExistentDir "-ohi" hi)
 154  where
 155    nonExistentDir flg dir =
 156      throwDyn (CmdLineError ("error: directory portion of " ++
 157                              show dir ++ " does not exist (used with " ++
 158                              show flg ++ " option.)"))
 159
 160 GLOBAL_VAR(v_Object_suf,  Nothing, Maybe String)
 161 GLOBAL_VAR(v_HC_suf,      Nothing, Maybe String)
 162 GLOBAL_VAR(v_Hi_dir,      Nothing, Maybe String)
 163 GLOBAL_VAR(v_Hi_suf,      "hi",    String)
 164
 165 GLOBAL_VAR(v_Ld_inputs, [],      [String])
 166
 167 odir_ify :: String -> IO String
 168 odir_ify f = do
 169   odir_opt <- readIORef v_Output_dir
 170   case odir_opt of
 171         Nothing -> return f
 172         Just d  -> return (newdir d f)
 173
 174 osuf_ify :: String -> IO String
 175 osuf_ify f = do
 176   osuf_opt <- readIORef v_Object_suf
 177   case osuf_opt of
 178         Nothing -> return f
 179         Just s  -> return (newsuf s f)
 180
 181 -----------------------------------------------------------------------------
 182 -- Compiler optimisation options
 183
 184 GLOBAL_VAR(v_OptLevel, 0, Int)
 185
 186 setOptLevel :: Int -> IO ()
 187 setOptLevel n = do
 188   when (n >= 1) $ setLang HscC          -- turn on -fvia-C with -O
 189   writeIORef v_OptLevel n
 190
 191 GLOBAL_VAR(v_minus_o2_for_C,            False, Bool)
 192 GLOBAL_VAR(v_MaxSimplifierIterations,   4,     Int)
 193 GLOBAL_VAR(v_StgStats,                  False, Bool)
 194 GLOBAL_VAR(v_UsageSPInf,                False, Bool)  -- Off by default
 195 GLOBAL_VAR(v_Strictness,                True,  Bool)
 196 GLOBAL_VAR(v_CSE,                       True,  Bool)
 197 GLOBAL_VAR(v_RuleCheck,                 Nothing,  Maybe String)
 198
 199 -- these are the static flags you get without -O.
 200 hsc_minusNoO_flags =
 201        [
 202         "-fignore-interface-pragmas",
 203         "-fomit-interface-pragmas",
 204         "-fdo-lambda-eta-expansion",    -- This one is important for a tiresome reason:
 205                                         -- we want to make sure that the bindings for data
 206                                         -- constructors are eta-expanded.  This is probably
 207                                         -- a good thing anyway, but it seems fragile.
 208         "-flet-no-escape"
 209         ]
 210
 211 -- these are the static flags you get when -O is on.
 212 hsc_minusO_flags =
 213   [
 214         "-fignore-asserts",
 215         "-ffoldr-build-on",
 216         "-fdo-eta-reduction",
 217         "-fdo-lambda-eta-expansion",
 218         "-fcase-merge",
 219         "-flet-to-case",
 220         "-flet-no-escape"
 221    ]
 222
 223 hsc_minusO2_flags = hsc_minusO_flags    -- for now
 224
 225 getStaticOptimisationFlags 0 = hsc_minusNoO_flags
 226 getStaticOptimisationFlags 1 = hsc_minusO_flags
 227 getStaticOptimisationFlags n = hsc_minusO2_flags
 228
 229 buildCoreToDo :: IO [CoreToDo]
 230 buildCoreToDo = do
 231    opt_level  <- readIORef v_OptLevel
 232    max_iter   <- readIORef v_MaxSimplifierIterations
 233    usageSP    <- readIORef v_UsageSPInf
 234    strictness <- readIORef v_Strictness
 235    cse        <- readIORef v_CSE
 236    rule_check <- readIORef v_RuleCheck
 237
 238    if opt_level == 0 then return
 239       [
 240         CoreDoSimplify (SimplPhase 0) [
 241             MaxSimplifierIterations max_iter
 242         ]
 243       ]
 244
 245     else {- opt_level >= 1 -} return [
 246
 247         -- initial simplify: mk specialiser happy: minimum effort please
 248         CoreDoSimplify SimplGently [
 249                         --      Simplify "gently"
 250                         -- Don't inline anything till full laziness has bitten
 251                         -- In particular, inlining wrappers inhibits floating
 252                         -- e.g. ...(case f x of ...)...
 253                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
 254                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
 255                         -- and now the redex (f x) isn't floatable any more
 256                         -- Similarly, don't apply any rules until after full
 257                         -- laziness.  Notably, list fusion can prevent floating.
 258
 259             NoCaseOfCase,
 260                         -- Don't do case-of-case transformations.
 261                         -- This makes full laziness work better
 262             MaxSimplifierIterations max_iter
 263         ],
 264
 265         -- Specialisation is best done before full laziness
 266         -- so that overloaded functions have all their dictionary lambdas manifest
 267         CoreDoSpecialising,
 268
 269         CoreDoFloatOutwards (FloatOutSw False False),
 270         CoreDoFloatInwards,
 271
 272         CoreDoSimplify (SimplPhase 2) [
 273                 -- Want to run with inline phase 2 after the specialiser to give
 274                 -- maximum chance for fusion to work before we inline build/augment
 275                 -- in phase 1.  This made a difference in 'ansi' where an
 276                 -- overloaded function wasn't inlined till too late.
 277            MaxSimplifierIterations max_iter
 278         ],
 279         case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
 280
 281         -- infer usage information here in case we need it later.
 282         -- (add more of these where you need them --KSW 1999-04)
 283         if usageSP then CoreDoUSPInf else CoreDoNothing,
 284
 285         CoreDoSimplify (SimplPhase 1) [
 286                 -- Need inline-phase2 here so that build/augment get
 287                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 288                 -- strictness in the function sumcode' if augment is not inlined
 289                 -- before strictness analysis runs
 290            MaxSimplifierIterations max_iter
 291         ],
 292         case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
 293
 294         CoreDoSimplify (SimplPhase 0) [
 295                 -- Phase 0: allow all Ids to be inlined now
 296                 -- This gets foldr inlined before strictness analysis
 297
 298            MaxSimplifierIterations 3
 299                 -- At least 3 iterations because otherwise we land up with
 300                 -- huge dead expressions because of an infelicity in the
 301                 -- simpifier.
 302                 --      let k = BIG in foldr k z xs
 303                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
 304                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
 305                 -- Don't stop now!
 306
 307         ],
 308         case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
 309
 310 #ifdef OLD_STRICTNESS
 311         CoreDoOldStrictness
 312 #endif
 313         if strictness then CoreDoStrictness else CoreDoNothing,
 314         CoreDoWorkerWrapper,
 315         CoreDoGlomBinds,
 316
 317         CoreDoSimplify (SimplPhase 0) [
 318            MaxSimplifierIterations max_iter
 319         ],
 320
 321         CoreDoFloatOutwards (FloatOutSw False   -- Not lambdas
 322                                         True),  -- Float constants
 323                 -- nofib/spectral/hartel/wang doubles in speed if you
 324                 -- do full laziness late in the day.  It only happens
 325                 -- after fusion and other stuff, so the early pass doesn't
 326                 -- catch it.  For the record, the redex is
 327                 --        f_el22 (f_el21 r_midblock)
 328
 329
 330         -- We want CSE to follow the final full-laziness pass, because it may
 331         -- succeed in commoning up things floated out by full laziness.
 332         -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
 333
 334         if cse then CoreCSE else CoreDoNothing,
 335
 336         CoreDoFloatInwards,
 337
 338 -- Case-liberation for -O2.  This should be after
 339 -- strictness analysis and the simplification which follows it.
 340
 341         case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
 342
 343         if opt_level >= 2 then
 344            CoreLiberateCase
 345         else
 346            CoreDoNothing,
 347         if opt_level >= 2 then
 348            CoreDoSpecConstr
 349         else
 350            CoreDoNothing,
 351
 352         -- Final clean-up simplification:
 353         CoreDoSimplify (SimplPhase 0) [
 354           MaxSimplifierIterations max_iter
 355         ]
 356      ]
 357
 358 buildStgToDo :: IO [ StgToDo ]
 359 buildStgToDo = do
 360   stg_stats <- readIORef v_StgStats
 361   let flags1 | stg_stats = [ D_stg_stats ]
 362              | otherwise = [ ]
 363
 364         -- STG passes
 365   ways_ <- readIORef v_Ways
 366   let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
 367              | otherwise            = flags1
 368
 369   return flags2
 370
 371 -----------------------------------------------------------------------------
 372 -- Paths & Libraries
 373
 374 split_marker = ':'   -- not configurable (ToDo)
 375
 376 v_Import_paths, v_Include_paths, v_Library_paths :: IORef [String]
 377 GLOBAL_VAR(v_Import_paths,  ["."], [String])
 378 GLOBAL_VAR(v_Include_paths, ["."], [String])
 379 GLOBAL_VAR(v_Library_paths, [],  [String])
 380
 381 GLOBAL_VAR(v_Cmdline_libraries,   [], [String])
 382
 383 #ifdef darwin_TARGET_OS
 384 GLOBAL_VAR(v_Framework_paths, [], [String])
 385 GLOBAL_VAR(v_Cmdline_frameworks, [], [String])
 386 #endif
 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, HSbase2 and HSbase3, which is needed due to a bug
 521      -- in the GNU linker (PEi386 backend). However, we still only
 522      -- have HSbase.a for static linking, not HSbase{1,2,3}.a
 523      -- getPackageLibraries is called to find the .a's to add to the static
 524      -- link line.  On Win32, this hACK detects HSbase{1,2,3} 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 #      if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS)
 534        = libs
 535 #      else
 536        = if   "HSbase1" `elem` libs && "HSbase2" `elem` libs && "HSbase3" `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 #ifdef darwin_TARGET_OS
 564 getPackageFrameworkPath  :: IO [String]
 565 getPackageFrameworkPath = do
 566   ps <- getPackageInfo
 567   return (nub (filter notNull (concatMap framework_dirs ps)))
 568
 569 getPackageFrameworks  :: IO [String]
 570 getPackageFrameworks = do
 571   ps <- getPackageInfo
 572   return (concatMap extra_frameworks ps)
 573 #endif
 574
 575 getPackageInfo :: IO [PackageConfig]
 576 getPackageInfo = do
 577   ps <- readIORef v_Packages
 578   getPackageDetails ps
 579
 580 getPackageDetails :: [String] -> IO [PackageConfig]
 581 getPackageDetails ps = do
 582   pkg_details <- readIORef v_Package_details
 583   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 584
 585 GLOBAL_VAR(v_Package_details, [], [PackageConfig])
 586
 587 lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig
 588 lookupPkg nm ps
 589    = case [p | p <- ps, name p == nm] of
 590         []    -> Nothing
 591         (p:_) -> Just p
 592
 593 -----------------------------------------------------------------------------
 594 -- Ways
 595
 596 -- The central concept of a "way" is that all objects in a given
 597 -- program must be compiled in the same "way".  Certain options change
 598 -- parameters of the virtual machine, eg. profiling adds an extra word
 599 -- to the object header, so profiling objects cannot be linked with
 600 -- non-profiling objects.
 601
 602 -- After parsing the command-line options, we determine which "way" we
 603 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 604
 605 -- We then find the "build-tag" associated with this way, and this
 606 -- becomes the suffix used to find .hi files and libraries used in
 607 -- this compilation.
 608
 609 GLOBAL_VAR(v_Build_tag, "", String)
 610
 611 data WayName
 612   = WayProf
 613   | WayUnreg
 614   | WayTicky
 615   | WayPar
 616   | WayGran
 617   | WaySMP
 618   | WayNDP
 619   | WayDebug
 620   | WayUser_a
 621   | WayUser_b
 622   | WayUser_c
 623   | WayUser_d
 624   | WayUser_e
 625   | WayUser_f
 626   | WayUser_g
 627   | WayUser_h
 628   | WayUser_i
 629   | WayUser_j
 630   | WayUser_k
 631   | WayUser_l
 632   | WayUser_m
 633   | WayUser_n
 634   | WayUser_o
 635   | WayUser_A
 636   | WayUser_B
 637   deriving (Eq,Ord)
 638
 639 GLOBAL_VAR(v_Ways, [] ,[WayName])
 640
 641 allowed_combination way = way `elem` combs
 642   where  -- the sub-lists must be ordered according to WayName,
 643          -- because findBuildTag sorts them
 644     combs                = [ [WayProf, WayUnreg],
 645                              [WayProf, WaySMP]  ,
 646                              [WayProf, WayNDP]  ]
 647
 648 findBuildTag :: IO [String]  -- new options
 649 findBuildTag = do
 650   way_names <- readIORef v_Ways
 651   case sort way_names of
 652      []  -> do  -- writeIORef v_Build_tag ""
 653                 return []
 654
 655      [w] -> do let details = lkupWay w
 656                writeIORef v_Build_tag (wayTag details)
 657                return (wayOpts details)
 658
 659      ws  -> if not (allowed_combination ws)
 660                 then throwDyn (CmdLineError $
 661                                 "combination not supported: "  ++
 662                                 foldr1 (\a b -> a ++ '/':b)
 663                                 (map (wayName . lkupWay) ws))
 664                 else let stuff = map lkupWay ws
 665                          tag   = concat (map wayTag stuff)
 666                          flags = map wayOpts stuff
 667                      in do
 668                      writeIORef v_Build_tag tag
 669                      return (concat flags)
 670
 671 lkupWay w =
 672    case lookup w way_details of
 673         Nothing -> error "findBuildTag"
 674         Just details -> details
 675
 676 data Way = Way {
 677   wayTag   :: String,
 678   wayName  :: String,
 679   wayOpts  :: [String]
 680   }
 681
 682 way_details :: [ (WayName, Way) ]
 683 way_details =
 684   [ (WayProf, Way  "p" "Profiling"
 685         [ "-fscc-profiling"
 686         , "-DPROFILING"
 687         , "-optc-DPROFILING"
 688         , "-fvia-C" ]),
 689
 690     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 691         [ "-fticky-ticky"
 692         , "-DTICKY_TICKY"
 693         , "-optc-DTICKY_TICKY"
 694         , "-fvia-C" ]),
 695
 696     (WayUnreg, Way  "u" "Unregisterised"
 697         unregFlags ),
 698
 699     -- optl's below to tell linker where to find the PVM library -- HWL
 700     (WayPar, Way  "mp" "Parallel"
 701         [ "-fparallel"
 702         , "-D__PARALLEL_HASKELL__"
 703         , "-optc-DPAR"
 704         , "-package concurrent"
 705         , "-optc-w"
 706         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 707         , "-optl-lpvm3"
 708         , "-optl-lgpvm3"
 709         , "-fvia-C" ]),
 710
 711     -- at the moment we only change the RTS and could share compiler and libs!
 712     (WayPar, Way  "mt" "Parallel ticky profiling"
 713         [ "-fparallel"
 714         , "-D__PARALLEL_HASKELL__"
 715         , "-optc-DPAR"
 716         , "-optc-DPAR_TICKY"
 717         , "-package concurrent"
 718         , "-optc-w"
 719         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 720         , "-optl-lpvm3"
 721         , "-optl-lgpvm3"
 722         , "-fvia-C" ]),
 723
 724     (WayPar, Way  "md" "Distributed"
 725         [ "-fparallel"
 726         , "-D__PARALLEL_HASKELL__"
 727         , "-D__DISTRIBUTED_HASKELL__"
 728         , "-optc-DPAR"
 729         , "-optc-DDIST"
 730         , "-package concurrent"
 731         , "-optc-w"
 732         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 733         , "-optl-lpvm3"
 734         , "-optl-lgpvm3"
 735         , "-fvia-C" ]),
 736
 737     (WayGran, Way  "mg" "GranSim"
 738         [ "-fgransim"
 739         , "-D__GRANSIM__"
 740         , "-optc-DGRAN"
 741         , "-package concurrent"
 742         , "-fvia-C" ]),
 743
 744     (WaySMP, Way  "s" "SMP"
 745         [ "-fsmp"
 746         , "-optc-pthread"
 747         , "-optl-pthread"
 748         , "-optc-DSMP"
 749         , "-fvia-C" ]),
 750
 751     (WayNDP, Way  "ndp" "Nested data parallelism"
 752         [ "-fparr"
 753         , "-fflatten"]),
 754
 755     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 756     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 757     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 758     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 759     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 760     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 761     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 762     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 763     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 764     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 765     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 766     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 767     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 768     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 769     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 770     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 771     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 772   ]
 773
 774 unregFlags =
 775    [ "-optc-DNO_REGS"
 776    , "-optc-DUSE_MINIINTERPRETER"
 777    , "-fno-asm-mangling"
 778    , "-funregisterised"
 779    , "-fvia-C" ]
 780
 781 -----------------------------------------------------------------------------
 782 -- Options for particular phases
 783
 784 GLOBAL_VAR(v_Opt_dep,    [], [String])
 785 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 786 GLOBAL_VAR(v_Opt_C,      [], [String])
 787 GLOBAL_VAR(v_Opt_l,      [], [String])
 788 GLOBAL_VAR(v_Opt_dll,    [], [String])
 789
 790 getStaticOpts :: IORef [String] -> IO [String]
 791 getStaticOpts ref = readIORef ref >>= return . reverse