ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.77 2002/04/22 16:06:36 simonpj Exp $
   3 --
   4 -- Settings for the driver
   5 --
   6 -- (c) The University of Glasgow 2002
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverState where
  11
  12 #include "../includes/config.h"
  13 #include "HsVersions.h"
  14
  15 import SysTools         ( getTopDir )
  16 import ParsePkgConf     ( loadPackageConfig )
  17 import Packages         ( PackageConfig(..), mungePackagePaths )
  18 import CmdLineOpts
  19 import DriverPhases
  20 import DriverUtil
  21 import Util
  22 import Config
  23 import Exception
  24 import IOExts
  25 import Panic
  26
  27 import List
  28 import Char
  29 import Monad
  30 import Maybe     ( fromJust, isJust )
  31 import Directory ( doesDirectoryExist )
  32
  33 -----------------------------------------------------------------------------
  34 -- non-configured things
  35
  36 cHaskell1Version = "5" -- i.e., Haskell 98
  37
  38 -----------------------------------------------------------------------------
  39 -- GHC modes of operation
  40
  41 data GhcMode
  42   = DoMkDependHS                        -- ghc -M
  43   | DoMkDLL                             -- ghc --mk-dll
  44   | StopBefore Phase                    -- ghc -E | -C | -S | -c
  45   | DoMake                              -- ghc --make
  46   | DoInteractive                       -- ghc --interactive
  47   | DoLink                              -- [ the default ]
  48   deriving (Eq,Show)
  49
  50 GLOBAL_VAR(v_GhcMode,     DoLink, GhcMode)
  51 GLOBAL_VAR(v_GhcModeFlag, "",     String)
  52
  53 setMode :: GhcMode -> String -> IO ()
  54 setMode m flag = do
  55   old_mode <- readIORef v_GhcMode
  56   old_flag <- readIORef v_GhcModeFlag
  57   when (notNull (old_flag)) $
  58       throwDyn (UsageError
  59           ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
  60   writeIORef v_GhcMode m
  61   writeIORef v_GhcModeFlag flag
  62
  63 isCompManagerMode DoMake        = True
  64 isCompManagerMode DoInteractive = True
  65 isCompManagerMode _             = False
  66
  67 -----------------------------------------------------------------------------
  68 -- Global compilation flags
  69
  70 -- Cpp-related flags
  71 v_Hs_source_cpp_opts = global
  72         [ "-D__HASKELL1__="++cHaskell1Version
  73         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
  74         , "-D__HASKELL98__"
  75         , "-D__CONCURRENT_HASKELL__"
  76         ]
  77 {-# NOINLINE v_Hs_source_cpp_opts #-}
  78
  79
  80 -- Keep output from intermediate phases
  81 GLOBAL_VAR(v_Keep_hi_diffs,             False,          Bool)
  82 GLOBAL_VAR(v_Keep_hc_files,             False,          Bool)
  83 GLOBAL_VAR(v_Keep_s_files,              False,          Bool)
  84 GLOBAL_VAR(v_Keep_raw_s_files,          False,          Bool)
  85 GLOBAL_VAR(v_Keep_tmp_files,            False,          Bool)
  86 #ifdef ILX
  87 GLOBAL_VAR(v_Keep_il_files,             False,          Bool)
  88 GLOBAL_VAR(v_Keep_ilx_files,            False,          Bool)
  89 #endif
  90
  91 -- Misc
  92 GLOBAL_VAR(v_Scale_sizes_by,            1.0,            Double)
  93 GLOBAL_VAR(v_Static,                    True,           Bool)
  94 GLOBAL_VAR(v_NoHsMain,                  False,          Bool)
  95 GLOBAL_VAR(v_Recomp,                    True,           Bool)
  96 GLOBAL_VAR(v_Collect_ghc_timing,        False,          Bool)
  97 GLOBAL_VAR(v_Do_asm_mangling,           True,           Bool)
  98 GLOBAL_VAR(v_Excess_precision,          False,          Bool)
  99 GLOBAL_VAR(v_Read_DotGHCi,              True,           Bool)
 100
 101 -- Preprocessor flags
 102 GLOBAL_VAR(v_Hs_source_pp_opts, [], [String])
 103
 104 -----------------------------------------------------------------------------
 105 -- Splitting object files (for libraries)
 106
 107 GLOBAL_VAR(v_Split_object_files,        False,          Bool)
 108 GLOBAL_VAR(v_Split_info,                ("",0),         (String,Int))
 109         -- The split prefix and number of files
 110
 111
 112 can_split :: Bool
 113 can_split =  prefixMatch "i386"    cTARGETPLATFORM
 114           || prefixMatch "alpha"   cTARGETPLATFORM
 115           || prefixMatch "hppa"    cTARGETPLATFORM
 116           || prefixMatch "m68k"    cTARGETPLATFORM
 117           || prefixMatch "mips"    cTARGETPLATFORM
 118           || prefixMatch "powerpc" cTARGETPLATFORM
 119           || prefixMatch "rs6000"  cTARGETPLATFORM
 120           || prefixMatch "sparc"   cTARGETPLATFORM
 121
 122 -----------------------------------------------------------------------------
 123 -- Compiler output options
 124
 125 GLOBAL_VAR(v_Output_dir,  Nothing, Maybe String)
 126 GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
 127 GLOBAL_VAR(v_Output_hi,   Nothing, Maybe String)
 128
 129 -- called to verify that the output files & directories
 130 -- point somewhere valid.
 131 --
 132 -- The assumption is that the directory portion of these output
 133 -- options will have to exist by the time 'verifyOutputFiles'
 134 -- is invoked.
 135 --
 136 verifyOutputFiles :: IO ()
 137 verifyOutputFiles = do
 138   odir <- readIORef v_Output_dir
 139   when (isJust odir) $ do
 140      let dir = fromJust odir
 141      flg <- doesDirectoryExist dir
 142      when (not flg) (nonExistentDir "-odir" dir)
 143   ofile <- readIORef v_Output_file
 144   when (isJust ofile) $ do
 145      let fn = fromJust ofile
 146      flg <- doesDirNameExist fn
 147      when (not flg) (nonExistentDir "-o" fn)
 148   ohi <- readIORef v_Output_hi
 149   when (isJust ohi) $ do
 150      let hi = fromJust ohi
 151      flg <- doesDirNameExist hi
 152      when (not flg) (nonExistentDir "-ohi" hi)
 153  where
 154    nonExistentDir flg dir =
 155      throwDyn (CmdLineError ("error: directory portion of " ++
 156                              show dir ++ " does not exist (used with " ++
 157                              show flg ++ " option.)"))
 158
 159 GLOBAL_VAR(v_Object_suf,  Nothing, Maybe String)
 160 GLOBAL_VAR(v_HC_suf,      Nothing, Maybe String)
 161 GLOBAL_VAR(v_Hi_dir,      Nothing, Maybe String)
 162 GLOBAL_VAR(v_Hi_suf,      "hi",    String)
 163
 164 GLOBAL_VAR(v_Ld_inputs, [],      [String])
 165
 166 odir_ify :: String -> IO String
 167 odir_ify f = do
 168   odir_opt <- readIORef v_Output_dir
 169   case odir_opt of
 170         Nothing -> return f
 171         Just d  -> return (newdir d f)
 172
 173 osuf_ify :: String -> IO String
 174 osuf_ify f = do
 175   osuf_opt <- readIORef v_Object_suf
 176   case osuf_opt of
 177         Nothing -> return f
 178         Just s  -> return (newsuf s f)
 179
 180 -----------------------------------------------------------------------------
 181 -- Compiler optimisation options
 182
 183 GLOBAL_VAR(v_OptLevel, 0, Int)
 184
 185 setOptLevel :: Int -> IO ()
 186 setOptLevel n = do
 187   when (n >= 1) $ setLang HscC          -- turn on -fvia-C with -O
 188   writeIORef v_OptLevel n
 189
 190 GLOBAL_VAR(v_minus_o2_for_C,            False, Bool)
 191 GLOBAL_VAR(v_MaxSimplifierIterations,   4,     Int)
 192 GLOBAL_VAR(v_StgStats,                  False, Bool)
 193 GLOBAL_VAR(v_UsageSPInf,                False, Bool)  -- Off by default
 194 GLOBAL_VAR(v_Strictness,                True,  Bool)
 195 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 addToDirList :: IORef [String] -> String -> IO ()
 383 addToDirList ref path
 384   = do paths           <- readIORef ref
 385        shiny_new_ones  <- splitUp path
 386        writeIORef ref (paths ++ filter notNull shiny_new_ones)
 387                 -- empty paths are ignored: there might be a trailing
 388                 -- ':' in the initial list, for example.  Empty paths can
 389                 -- cause confusion when they are translated into -I options
 390                 -- for passing to gcc.
 391   where
 392     splitUp ::String -> IO [String]
 393 #ifdef mingw32_TARGET_OS
 394      -- 'hybrid' support for DOS-style paths in directory lists.
 395      --
 396      -- That is, if "foo:bar:baz" is used, this interpreted as
 397      -- consisting of three entries, 'foo', 'bar', 'baz'.
 398      -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted
 399      -- as four elts, "c:/foo", "c:\\foo", "x", and "/bar" --
 400      -- *provided* c:/foo exists and x:/bar doesn't.
 401      --
 402      -- Notice that no attempt is made to fully replace the 'standard'
 403      -- split marker ':' with the Windows / DOS one, ';'. The reason being
 404      -- that this will cause too much breakage for users & ':' will
 405      -- work fine even with DOS paths, if you're not insisting on being silly.
 406      -- So, use either.
 407     splitUp []         = return []
 408     splitUp (x:':':div:xs)
 409       | div `elem` dir_markers = do
 410           let (p,rs) = findNextPath xs
 411           ps  <- splitUp rs
 412            {-
 413              Consult the file system to check the interpretation
 414              of (x:':':div:p) -- this is arguably excessive, we
 415              could skip this test & just say that it is a valid
 416              dir path.
 417            -}
 418           flg <- doesDirectoryExist (x:':':div:p)
 419           if flg then
 420              return ((x:':':div:p):ps)
 421            else
 422              return ([x]:(div:p):ps)
 423     splitUp xs = do
 424       let (p,rs) = findNextPath xs
 425       ps <- splitUp rs
 426       return (cons p ps)
 427
 428     cons "" xs = xs
 429     cons x  xs = x:xs
 430
 431     -- will be called either when we've consumed nought or the "<Drive>:/" part of
 432     -- a DOS path, so splitting is just a Q of finding the next split marker.
 433     findNextPath xs =
 434         case break (`elem` split_markers) xs of
 435            (p, d:ds) -> (p, ds)
 436            (p, xs)   -> (p, xs)
 437
 438     split_markers :: [Char]
 439     split_markers = [':', ';']
 440
 441     dir_markers :: [Char]
 442     dir_markers = ['/', '\\']
 443
 444 #else
 445     splitUp xs = return (split split_marker xs)
 446 #endif
 447
 448 GLOBAL_VAR(v_HCHeader, "", String)
 449
 450 -----------------------------------------------------------------------------
 451 -- Packages
 452
 453 -- package list is maintained in dependency order
 454 GLOBAL_VAR(v_Packages, ("haskell98":"base":"rts":[]), [String])
 455
 456 readPackageConf :: String -> IO ()
 457 readPackageConf conf_file = do
 458   proto_pkg_details <- loadPackageConfig conf_file
 459   top_dir <- getTopDir
 460   let pkg_details    = mungePackagePaths top_dir proto_pkg_details
 461   old_pkg_details <- readIORef v_Package_details
 462
 463   let -- new package override old ones
 464       new_pkg_names = map name pkg_details
 465       filtered_old_pkg_details =
 466          filter (\p -> name p `notElem` new_pkg_names) old_pkg_details
 467
 468   writeIORef v_Package_details (pkg_details ++ filtered_old_pkg_details)
 469
 470 addPackage :: String -> IO ()
 471 addPackage package
 472   = do pkg_details <- readIORef v_Package_details
 473        case lookupPkg package pkg_details of
 474           Nothing -> throwDyn (CmdLineError ("unknown package name: " ++ package))
 475           Just details -> do
 476             ps <- readIORef v_Packages
 477             unless (package `elem` ps) $ do
 478                 mapM_ addPackage (package_deps details)
 479                 ps <- readIORef v_Packages
 480                 writeIORef v_Packages (package:ps)
 481
 482 getPackageImportPath   :: IO [String]
 483 getPackageImportPath = do
 484   ps <- getPackageInfo
 485   return (nub (filter notNull (concatMap import_dirs ps)))
 486
 487 getPackageIncludePath   :: IO [String]
 488 getPackageIncludePath = do
 489   ps <- getPackageInfo
 490   return (nub (filter notNull (concatMap include_dirs ps)))
 491
 492         -- includes are in reverse dependency order (i.e. rts first)
 493 getPackageCIncludes   :: IO [String]
 494 getPackageCIncludes = do
 495   ps <- getPackageInfo
 496   return (reverse (nub (filter notNull (concatMap c_includes ps))))
 497
 498 getPackageLibraryPath  :: IO [String]
 499 getPackageLibraryPath = do
 500   ps <- getPackageInfo
 501   return (nub (filter notNull (concatMap library_dirs ps)))
 502
 503 getPackageLibraries    :: IO [String]
 504 getPackageLibraries = do
 505   ps <- getPackageInfo
 506   tag <- readIORef v_Build_tag
 507   let suffix = if null tag then "" else '_':tag
 508   return (concat (
 509         map (\p -> map (++suffix) (hACK (hs_libraries p)) ++ extra_libraries p) ps
 510      ))
 511   where
 512      -- This is a totally horrible (temporary) hack, for Win32.  Problem is
 513      -- that package.conf for Win32 says that the main prelude lib is
 514      -- split into HSbase1 and HSbase2, which is needed due to limitations in
 515      -- the PEi386 file format, to make GHCi work.  However, we still only
 516      -- have HSbase.a for static linking, not HSbase1.a and HSbase2.a.
 517      -- getPackageLibraries is called to find the .a's to add to the static
 518      -- link line.  On Win32, this hACK detects HSbase1 and HSbase2 and
 519      -- replaces them with HSbase, so static linking still works.
 520      -- Libraries needed for dynamic (GHCi) linking are discovered via
 521      -- different route (in InteractiveUI.linkPackage).
 522      -- See driver/PackageSrc.hs for the HSbase1/HSbase2 split definition.
 523      -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...)
 524      -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2]
 525      -- KAA 29 Mar  02: Same appalling hack for HSobjectio[1,2,3,4]
 526      hACK libs
 527 #      ifndef mingw32_TARGET_OS
 528        = libs
 529 #      else
 530        = if   "HSbase1" `elem` libs && "HSbase2" `elem` libs
 531          then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs
 532          else
 533          if   "HSwin321" `elem` libs && "HSwin322" `elem` libs
 534          then "HSwin32" : filter (not.(isPrefixOf "HSwin32")) libs
 535          else
 536          if   "HSobjectio1" `elem` libs && "HSobjectio2" `elem` libs && "HSobjectio3" `elem` libs && "HSobjectio4" `elem` libs
 537          then "HSobjectio" : filter (not.(isPrefixOf "HSobjectio")) libs
 538          else
 539          libs
 540 #      endif
 541
 542 getPackageExtraGhcOpts :: IO [String]
 543 getPackageExtraGhcOpts = do
 544   ps <- getPackageInfo
 545   return (concatMap extra_ghc_opts ps)
 546
 547 getPackageExtraCcOpts  :: IO [String]
 548 getPackageExtraCcOpts = do
 549   ps <- getPackageInfo
 550   return (concatMap extra_cc_opts ps)
 551
 552 getPackageExtraLdOpts  :: IO [String]
 553 getPackageExtraLdOpts = do
 554   ps <- getPackageInfo
 555   return (concatMap extra_ld_opts ps)
 556
 557 getPackageInfo :: IO [PackageConfig]
 558 getPackageInfo = do
 559   ps <- readIORef v_Packages
 560   getPackageDetails ps
 561
 562 getPackageDetails :: [String] -> IO [PackageConfig]
 563 getPackageDetails ps = do
 564   pkg_details <- readIORef v_Package_details
 565   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 566
 567 GLOBAL_VAR(v_Package_details, [], [PackageConfig])
 568
 569 lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig
 570 lookupPkg nm ps
 571    = case [p | p <- ps, name p == nm] of
 572         []    -> Nothing
 573         (p:_) -> Just p
 574
 575 -----------------------------------------------------------------------------
 576 -- Ways
 577
 578 -- The central concept of a "way" is that all objects in a given
 579 -- program must be compiled in the same "way".  Certain options change
 580 -- parameters of the virtual machine, eg. profiling adds an extra word
 581 -- to the object header, so profiling objects cannot be linked with
 582 -- non-profiling objects.
 583
 584 -- After parsing the command-line options, we determine which "way" we
 585 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 586
 587 -- We then find the "build-tag" associated with this way, and this
 588 -- becomes the suffix used to find .hi files and libraries used in
 589 -- this compilation.
 590
 591 GLOBAL_VAR(v_Build_tag, "", String)
 592
 593 data WayName
 594   = WayProf
 595   | WayUnreg
 596   | WayTicky
 597   | WayPar
 598   | WayGran
 599   | WaySMP
 600   | WayNDP
 601   | WayDebug
 602   | WayUser_a
 603   | WayUser_b
 604   | WayUser_c
 605   | WayUser_d
 606   | WayUser_e
 607   | WayUser_f
 608   | WayUser_g
 609   | WayUser_h
 610   | WayUser_i
 611   | WayUser_j
 612   | WayUser_k
 613   | WayUser_l
 614   | WayUser_m
 615   | WayUser_n
 616   | WayUser_o
 617   | WayUser_A
 618   | WayUser_B
 619   deriving (Eq,Ord)
 620
 621 GLOBAL_VAR(v_Ways, [] ,[WayName])
 622
 623 allowed_combination way = way `elem` combs
 624   where  -- the sub-lists must be ordered according to WayName,
 625          -- because findBuildTag sorts them
 626     combs                = [ [WayProf, WayUnreg],
 627                              [WayProf, WaySMP]  ,
 628                              [WayProf, WayNDP]  ]
 629
 630 findBuildTag :: IO [String]  -- new options
 631 findBuildTag = do
 632   way_names <- readIORef v_Ways
 633   case sort way_names of
 634      []  -> do  -- writeIORef v_Build_tag ""
 635                 return []
 636
 637      [w] -> do let details = lkupWay w
 638                writeIORef v_Build_tag (wayTag details)
 639                return (wayOpts details)
 640
 641      ws  -> if not (allowed_combination ws)
 642                 then throwDyn (CmdLineError $
 643                                 "combination not supported: "  ++
 644                                 foldr1 (\a b -> a ++ '/':b)
 645                                 (map (wayName . lkupWay) ws))
 646                 else let stuff = map lkupWay ws
 647                          tag   = concat (map wayTag stuff)
 648                          flags = map wayOpts stuff
 649                      in do
 650                      writeIORef v_Build_tag tag
 651                      return (concat flags)
 652
 653 lkupWay w =
 654    case lookup w way_details of
 655         Nothing -> error "findBuildTag"
 656         Just details -> details
 657
 658 data Way = Way {
 659   wayTag   :: String,
 660   wayName  :: String,
 661   wayOpts  :: [String]
 662   }
 663
 664 way_details :: [ (WayName, Way) ]
 665 way_details =
 666   [ (WayProf, Way  "p" "Profiling"
 667         [ "-fscc-profiling"
 668         , "-DPROFILING"
 669         , "-optc-DPROFILING"
 670         , "-fvia-C" ]),
 671
 672     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 673         [ "-fticky-ticky"
 674         , "-DTICKY_TICKY"
 675         , "-optc-DTICKY_TICKY"
 676         , "-fvia-C" ]),
 677
 678     (WayUnreg, Way  "u" "Unregisterised"
 679         unregFlags ),
 680
 681     -- optl's below to tell linker where to find the PVM library -- HWL
 682     (WayPar, Way  "mp" "Parallel"
 683         [ "-fparallel"
 684         , "-D__PARALLEL_HASKELL__"
 685         , "-optc-DPAR"
 686         , "-package concurrent"
 687         , "-optc-w"
 688         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 689         , "-optl-lpvm3"
 690         , "-optl-lgpvm3"
 691         , "-fvia-C" ]),
 692
 693     -- at the moment we only change the RTS and could share compiler and libs!
 694     (WayPar, Way  "mt" "Parallel ticky profiling"
 695         [ "-fparallel"
 696         , "-D__PARALLEL_HASKELL__"
 697         , "-optc-DPAR"
 698         , "-optc-DPAR_TICKY"
 699         , "-package concurrent"
 700         , "-optc-w"
 701         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 702         , "-optl-lpvm3"
 703         , "-optl-lgpvm3"
 704         , "-fvia-C" ]),
 705
 706     (WayPar, Way  "md" "Distributed"
 707         [ "-fparallel"
 708         , "-D__PARALLEL_HASKELL__"
 709         , "-D__DISTRIBUTED_HASKELL__"
 710         , "-optc-DPAR"
 711         , "-optc-DDIST"
 712         , "-package concurrent"
 713         , "-optc-w"
 714         , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
 715         , "-optl-lpvm3"
 716         , "-optl-lgpvm3"
 717         , "-fvia-C" ]),
 718
 719     (WayGran, Way  "mg" "GranSim"
 720         [ "-fgransim"
 721         , "-D__GRANSIM__"
 722         , "-optc-DGRAN"
 723         , "-package concurrent"
 724         , "-fvia-C" ]),
 725
 726     (WaySMP, Way  "s" "SMP"
 727         [ "-fsmp"
 728         , "-optc-pthread"
 729         , "-optl-pthread"
 730         , "-optc-DSMP"
 731         , "-fvia-C" ]),
 732
 733     (WayNDP, Way  "ndp" "Nested data parallelism"
 734         [ "-fparr"
 735         , "-fflatten"]),
 736
 737     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 738     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 739     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 740     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 741     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 742     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 743     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 744     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 745     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 746     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 747     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 748     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 749     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 750     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 751     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 752     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 753     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 754   ]
 755
 756 unregFlags =
 757    [ "-optc-DNO_REGS"
 758    , "-optc-DUSE_MINIINTERPRETER"
 759    , "-fno-asm-mangling"
 760    , "-funregisterised"
 761    , "-fvia-C" ]
 762
 763 -----------------------------------------------------------------------------
 764 -- Options for particular phases
 765
 766 GLOBAL_VAR(v_Opt_dep,    [], [String])
 767 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 768 GLOBAL_VAR(v_Opt_C,      [], [String])
 769 GLOBAL_VAR(v_Opt_l,      [], [String])
 770 GLOBAL_VAR(v_Opt_dll,    [], [String])
 771
 772 getStaticOpts :: IORef [String] -> IO [String]
 773 getStaticOpts ref = readIORef ref >>= return . reverse