ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
   3 --
   4 -- Settings for the driver
   5 --
   6 -- (c) The University of Glasgow 2000
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module DriverState where
  11
  12 #include "HsVersions.h"
  13
  14 import CmStaticInfo
  15 import CmdLineOpts
  16 import DriverUtil
  17 import Util
  18 import Config
  19 import Array
  20
  21 import Exception
  22 import IOExts
  23
  24 import System
  25 import IO
  26 import List
  27 import Char
  28 import Monad
  29
  30 -----------------------------------------------------------------------------
  31 -- Driver state
  32
  33 -- certain flags can be specified on a per-file basis, in an OPTIONS
  34 -- pragma at the beginning of the source file.  This means that when
  35 -- compiling mulitple files, we have to restore the global option
  36 -- settings before compiling a new file.
  37 --
  38 -- The DriverState record contains the per-file-mutable state.
  39
  40 data DriverState = DriverState {
  41
  42         -- are we runing cpp on this file?
  43         cpp_flag                :: Bool,
  44
  45         -- misc
  46         stolen_x86_regs         :: Int,
  47         cmdline_hc_includes     :: [String],
  48
  49         -- options for a particular phase
  50         opt_L                   :: [String],
  51         opt_P                   :: [String],
  52         opt_c                   :: [String],
  53         opt_a                   :: [String],
  54         opt_m                   :: [String]
  55    }
  56
  57 initDriverState = DriverState {
  58         cpp_flag                = False,
  59         stolen_x86_regs         = 4,
  60         cmdline_hc_includes     = [],
  61         opt_L                   = [],
  62         opt_P                   = [],
  63         opt_c                   = [],
  64         opt_a                   = [],
  65         opt_m                   = [],
  66    }
  67
  68 GLOBAL_VAR(driver_state, initDriverState, DriverState)
  69
  70 readState :: (DriverState -> a) -> IO a
  71 readState f = readIORef driver_state >>= return . f
  72
  73 updateState :: (DriverState -> DriverState) -> IO ()
  74 updateState f = readIORef driver_state >>= writeIORef driver_state . f
  75
  76 addOpt_L     a = updateState (\s -> s{opt_L      =  a : opt_L      s})
  77 addOpt_P     a = updateState (\s -> s{opt_P      =  a : opt_P      s})
  78 addOpt_c     a = updateState (\s -> s{opt_c      =  a : opt_c      s})
  79 addOpt_a     a = updateState (\s -> s{opt_a      =  a : opt_a      s})
  80 addOpt_m     a = updateState (\s -> s{opt_m      =  a : opt_m      s})
  81
  82 addCmdlineHCInclude a =
  83    updateState (\s -> s{cmdline_hc_includes =  a : cmdline_hc_includes s})
  84
  85         -- we add to the options from the front, so we need to reverse the list
  86 getOpts :: (DriverState -> [a]) -> IO [a]
  87 getOpts opts = readState opts >>= return . reverse
  88
  89 -----------------------------------------------------------------------------
  90 -- non-configured things
  91
  92 cHaskell1Version = "5" -- i.e., Haskell 98
  93
  94 -----------------------------------------------------------------------------
  95 -- Global compilation flags
  96
  97 -- Cpp-related flags
  98 hs_source_cpp_opts = global
  99         [ "-D__HASKELL1__="++cHaskell1Version
 100         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
 101         , "-D__HASKELL98__"
 102         , "-D__CONCURRENT_HASKELL__"
 103         ]
 104
 105 -- Verbose
 106 GLOBAL_VAR(verbose, False, Bool)
 107 is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
 108
 109 -- where to keep temporary files
 110 GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 111
 112 -- Keep output from intermediate phases
 113 GLOBAL_VAR(keep_hi_diffs,       False,          Bool)
 114 GLOBAL_VAR(keep_hc_files,       False,          Bool)
 115 GLOBAL_VAR(keep_s_files,        False,          Bool)
 116 GLOBAL_VAR(keep_raw_s_files,    False,          Bool)
 117 GLOBAL_VAR(keep_tmp_files,      False,          Bool)
 118
 119 -- Misc
 120 GLOBAL_VAR(scale_sizes_by,      1.0,            Double)
 121 GLOBAL_VAR(dry_run,             False,          Bool)
 122 #if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
 123 GLOBAL_VAR(static,              True,           Bool)
 124 #else
 125 GLOBAL_VAR(static,              False,          Bool)
 126 #endif
 127 GLOBAL_VAR(recomp,              True,           Bool)
 128 GLOBAL_VAR(collect_ghc_timing,  False,          Bool)
 129 GLOBAL_VAR(do_asm_mangling,     True,           Bool)
 130 GLOBAL_VAR(excess_precision,    False,          Bool)
 131
 132 -----------------------------------------------------------------------------
 133 -- Splitting object files (for libraries)
 134
 135 GLOBAL_VAR(split_object_files,  False,          Bool)
 136 GLOBAL_VAR(split_prefix,        "",             String)
 137 GLOBAL_VAR(n_split_files,       0,              Int)
 138
 139 can_split :: Bool
 140 can_split =  prefixMatch "i386" cTARGETPLATFORM
 141           || prefixMatch "alpha" cTARGETPLATFORM
 142           || prefixMatch "hppa" cTARGETPLATFORM
 143           || prefixMatch "m68k" cTARGETPLATFORM
 144           || prefixMatch "mips" cTARGETPLATFORM
 145           || prefixMatch "powerpc" cTARGETPLATFORM
 146           || prefixMatch "rs6000" cTARGETPLATFORM
 147           || prefixMatch "sparc" cTARGETPLATFORM
 148
 149 -----------------------------------------------------------------------------
 150 -- Compiler output options
 151
 152 GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
 153                          (prefixMatch "i386" cTARGETPLATFORM ||
 154                           prefixMatch "sparc" cTARGETPLATFORM)
 155                         then  HscAsm
 156                         else  HscC,
 157            HscLang)
 158
 159 GLOBAL_VAR(output_dir,  Nothing, Maybe String)
 160 GLOBAL_VAR(output_suf,  Nothing, Maybe String)
 161 GLOBAL_VAR(output_file, Nothing, Maybe String)
 162 GLOBAL_VAR(output_hi,   Nothing, Maybe String)
 163
 164 GLOBAL_VAR(ld_inputs,   [],      [String])
 165
 166 odir_ify :: String -> IO String
 167 odir_ify f = do
 168   odir_opt <- readIORef 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 output_suf
 176   case osuf_opt of
 177         Nothing -> return f
 178         Just s  -> return (newsuf s f)
 179
 180 -----------------------------------------------------------------------------
 181 -- Hi Files
 182
 183 GLOBAL_VAR(produceHi,           True,   Bool)
 184 GLOBAL_VAR(hi_on_stdout,        False,  Bool)
 185 GLOBAL_VAR(hi_suf,              "hi",   String)
 186
 187 -----------------------------------------------------------------------------
 188 -- Warnings & sanity checking
 189
 190 -- Warning packages that are controlled by -W and -Wall.  The 'standard'
 191 -- warnings that you get all the time are
 192 --
 193 --         -fwarn-overlapping-patterns
 194 --         -fwarn-missing-methods
 195 --         -fwarn-missing-fields
 196 --         -fwarn-deprecations
 197 --         -fwarn-duplicate-exports
 198 --
 199 -- these are turned off by -Wnot.
 200
 201
 202 standardWarnings  = [ "-fwarn-overlapping-patterns"
 203                     , "-fwarn-missing-methods"
 204                     , "-fwarn-missing-fields"
 205                     , "-fwarn-deprecations"
 206                     , "-fwarn-duplicate-exports"
 207                     ]
 208 minusWOpts        = standardWarnings ++
 209                     [ "-fwarn-unused-binds"
 210                     , "-fwarn-unused-matches"
 211                     , "-fwarn-incomplete-patterns"
 212                     , "-fwarn-unused-imports"
 213                     ]
 214 minusWallOpts     = minusWOpts ++
 215                     [ "-fwarn-type-defaults"
 216                     , "-fwarn-name-shadowing"
 217                     , "-fwarn-missing-signatures"
 218                     , "-fwarn-hi-shadowing"
 219                     ]
 220
 221 data WarningState = W_default | W_ | W_all | W_not
 222 GLOBAL_VAR(warning_opt, W_default, WarningState)
 223
 224 -----------------------------------------------------------------------------
 225 -- Compiler optimisation options
 226
 227 GLOBAL_VAR(opt_level, 0, Int)
 228
 229 setOptLevel :: String -> IO ()
 230 setOptLevel ""              = do { writeIORef opt_level 1; go_via_C }
 231 setOptLevel "not"           = writeIORef opt_level 0
 232 setOptLevel [c] | isDigit c = do
 233    let level = ord c - ord '0'
 234    writeIORef opt_level level
 235    when (level >= 1) go_via_C
 236 setOptLevel s = unknownFlagErr ("-O"++s)
 237
 238 go_via_C = do
 239    l <- readIORef hsc_lang
 240    case l of { HscAsm -> writeIORef hsc_lang HscC;
 241                _other -> return () }
 242
 243 GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
 244
 245 GLOBAL_VAR(opt_MaxSimplifierIterations, 4,     Int)
 246 GLOBAL_VAR(opt_StgStats,                False, Bool)
 247 GLOBAL_VAR(opt_UsageSPInf,              False, Bool)  -- Off by default
 248 GLOBAL_VAR(opt_Strictness,              True,  Bool)
 249 GLOBAL_VAR(opt_CPR,                     True,  Bool)
 250
 251 hsc_minusO2_flags = hsc_minusO_flags    -- for now
 252
 253 hsc_minusNoO_flags = do
 254   iter        <- readIORef opt_MaxSimplifierIterations
 255   return [
 256         "-fignore-interface-pragmas",
 257         "-fomit-interface-pragmas"
 258         ]
 259
 260 hsc_minusO_flags = do
 261   stgstats   <- readIORef opt_StgStats
 262
 263   return [
 264         "-ffoldr-build-on",
 265         "-fdo-eta-reduction",
 266         "-fdo-lambda-eta-expansion",
 267         "-fcase-of-case",
 268         "-fcase-merge",
 269         "-flet-to-case"
 270    ]
 271
 272 build_CoreToDo
 273    :: Int       -- opt level
 274    -> Int       -- max iterations
 275    -> Bool      -- do usageSP
 276    -> Bool      -- do strictness
 277    -> Bool      -- do CPR
 278    -> Bool      -- do CSE
 279    -> [CoreToDo]
 280
 281 build_CoreToDo level max_iter usageSP strictness cpr cse
 282   | level == 0 = [
 283         CoreDoSimplify (isAmongSimpl [
 284             MaxSimplifierIterations max_iter
 285         ])
 286       ]
 287
 288   | level >= 1 = [
 289
 290         -- initial simplify: mk specialiser happy: minimum effort please
 291         CoreDoSimplify (isAmongSimpl [
 292             SimplInlinePhase 0,
 293                         -- Don't inline anything till full laziness has bitten
 294                         -- In particular, inlining wrappers inhibits floating
 295                         -- e.g. ...(case f x of ...)...
 296                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
 297                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
 298                         -- and now the redex (f x) isn't floatable any more
 299             DontApplyRules,
 300                         -- Similarly, don't apply any rules until after full
 301                         -- laziness.  Notably, list fusion can prevent floating.
 302             NoCaseOfCase,
 303                         -- Don't do case-of-case transformations.
 304                         -- This makes full laziness work better
 305             MaxSimplifierIterations max_iter
 306         ]),
 307
 308         -- Specialisation is best done before full laziness
 309         -- so that overloaded functions have all their dictionary lambdas manifest
 310         CoreDoSpecialising,
 311
 312         CoreDoFloatOutwards False{-not full-},
 313         CoreDoFloatInwards,
 314
 315         CoreDoSimplify (isAmongSimpl [
 316            SimplInlinePhase 1,
 317                 -- Want to run with inline phase 1 after the specialiser to give
 318                 -- maximum chance for fusion to work before we inline build/augment
 319                 -- in phase 2.  This made a difference in 'ansi' where an
 320                 -- overloaded function wasn't inlined till too late.
 321            MaxSimplifierIterations max_iter
 322         ]),
 323
 324         -- infer usage information here in case we need it later.
 325         -- (add more of these where you need them --KSW 1999-04)
 326         if usageSP then CoreDoUSPInf else CoreDoNothing,
 327
 328         CoreDoSimplify (isAmongSimpl [
 329                 -- Need inline-phase2 here so that build/augment get
 330                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 331                 -- strictness in the function sumcode' if augment is not inlined
 332                 -- before strictness analysis runs
 333            SimplInlinePhase 2,
 334            MaxSimplifierIterations max_iter
 335         ]),
 336
 337         CoreDoSimplify (isAmongSimpl [
 338            MaxSimplifierIterations 2
 339                 -- No -finline-phase: allow all Ids to be inlined now
 340                 -- This gets foldr inlined before strictness analysis
 341         ]),
 342
 343         if strictness then CoreDoStrictness else CoreDoNothing,
 344         if cpr        then CoreDoCPResult   else CoreDoNothing,
 345         CoreDoWorkerWrapper,
 346         CoreDoGlomBinds,
 347
 348         CoreDoSimplify (isAmongSimpl [
 349            MaxSimplifierIterations max_iter
 350                 -- No -finline-phase: allow all Ids to be inlined now
 351         ]),
 352
 353         CoreDoFloatOutwards False{-not full-},
 354                 -- nofib/spectral/hartel/wang doubles in speed if you
 355                 -- do full laziness late in the day.  It only happens
 356                 -- after fusion and other stuff, so the early pass doesn't
 357                 -- catch it.  For the record, the redex is
 358                 --        f_el22 (f_el21 r_midblock)
 359
 360 -- Leave out lambda lifting for now
 361 --        "-fsimplify", -- Tidy up results of full laziness
 362 --          "[",
 363 --                "-fmax-simplifier-iterations2",
 364 --          "]",
 365 --        "-ffloat-outwards-full",
 366
 367         -- We want CSE to follow the final full-laziness pass, because it may
 368         -- succeed in commoning up things floated out by full laziness.
 369         --
 370         -- CSE must immediately follow a simplification pass, because it relies
 371         -- on the no-shadowing invariant.  See comments at the top of CSE.lhs
 372         -- So it must NOT follow float-inwards, which can give rise to shadowing,
 373         -- even if its input doesn't have shadows.  Hence putting it between
 374         -- the two passes.
 375         if cse then CoreCSE else CoreDoNothing,
 376
 377         CoreDoFloatInwards,
 378
 379 -- Case-liberation for -O2.  This should be after
 380 -- strictness analysis and the simplification which follows it.
 381
 382 --        ( ($OptLevel != 2)
 383 --        ? ""
 384 --        : "-fliberate-case -fsimplify [ $Oopt_FB_Support -ffloat-lets-exposing-whnf -ffloat-primops-ok -fcase-of-case -fdo-case-elim -fcase-merge -fdo-lambda-eta-expansion -freuse-con -flet-to-case $Oopt_PedanticBottoms $Oopt_MaxSimplifierIterations $Oopt_ShowSimplifierProgress ]" ),
 385 --
 386 --        "-fliberate-case",
 387
 388         -- Final clean-up simplification:
 389         CoreDoSimplify (isAmongSimpl [
 390           MaxSimplifierIterations max_iter
 391                 -- No -finline-phase: allow all Ids to be inlined now
 392         ])
 393    ]
 394
 395 -----------------------------------------------------------------------------
 396 -- Paths & Libraries
 397
 398 split_marker = ':'   -- not configurable (ToDo)
 399
 400 import_paths, include_paths, library_paths :: IORef [String]
 401 GLOBAL_VAR(import_paths,  ["."], [String])
 402 GLOBAL_VAR(include_paths, ["."], [String])
 403 GLOBAL_VAR(library_paths, [],    [String])
 404
 405 GLOBAL_VAR(cmdline_libraries,   [], [String])
 406
 407 addToDirList :: IORef [String] -> String -> IO ()
 408 addToDirList ref path
 409   = do paths <- readIORef ref
 410        writeIORef ref (paths ++ split split_marker path)
 411
 412 -----------------------------------------------------------------------------
 413 -- Packages
 414
 415 GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
 416
 417 -- package list is maintained in dependency order
 418 packages = global ["std", "rts", "gmp"] :: IORef [String]
 419 -- comma in value, so can't use macro, grrr
 420 {-# NOINLINE packages #-}
 421
 422 addPackage :: String -> IO ()
 423 addPackage package
 424   = do pkg_details <- readIORef package_details
 425        case lookupPkg package pkg_details of
 426           Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
 427           Just details -> do
 428             ps <- readIORef packages
 429             unless (package `elem` ps) $ do
 430                 mapM_ addPackage (package_deps details)
 431                 ps <- readIORef packages
 432                 writeIORef packages (package:ps)
 433
 434 getPackageImportPath   :: IO [String]
 435 getPackageImportPath = do
 436   ps <- readIORef packages
 437   ps' <- getPackageDetails ps
 438   return (nub (concat (map import_dirs ps')))
 439
 440 getPackageIncludePath   :: IO [String]
 441 getPackageIncludePath = do
 442   ps <- readIORef packages
 443   ps' <- getPackageDetails ps
 444   return (nub (filter (not.null) (concatMap include_dirs ps')))
 445
 446         -- includes are in reverse dependency order (i.e. rts first)
 447 getPackageCIncludes   :: IO [String]
 448 getPackageCIncludes = do
 449   ps <- readIORef packages
 450   ps' <- getPackageDetails ps
 451   return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
 452
 453 getPackageLibraryPath  :: IO [String]
 454 getPackageLibraryPath = do
 455   ps <- readIORef packages
 456   ps' <- getPackageDetails ps
 457   return (nub (concat (map library_dirs ps')))
 458
 459 getPackageLibraries    :: IO [String]
 460 getPackageLibraries = do
 461   ps <- readIORef packages
 462   ps' <- getPackageDetails ps
 463   tag <- readIORef build_tag
 464   let suffix = if null tag then "" else '_':tag
 465   return (concat (
 466         map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
 467      ))
 468
 469 getPackageExtraGhcOpts :: IO [String]
 470 getPackageExtraGhcOpts = do
 471   ps <- readIORef packages
 472   ps' <- getPackageDetails ps
 473   return (concatMap extra_ghc_opts ps')
 474
 475 getPackageExtraCcOpts  :: IO [String]
 476 getPackageExtraCcOpts = do
 477   ps <- readIORef packages
 478   ps' <- getPackageDetails ps
 479   return (concatMap extra_cc_opts ps')
 480
 481 getPackageExtraLdOpts  :: IO [String]
 482 getPackageExtraLdOpts = do
 483   ps <- readIORef packages
 484   ps' <- getPackageDetails ps
 485   return (concatMap extra_ld_opts ps')
 486
 487 getPackageDetails :: [String] -> IO [Package]
 488 getPackageDetails ps = do
 489   pkg_details <- readIORef package_details
 490   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 491
 492 GLOBAL_VAR(package_details, (error "package_details"), [Package])
 493
 494 lookupPkg :: String -> [Package] -> Maybe Package
 495 lookupPkg nm ps
 496    = case [p | p <- ps, name p == nm] of
 497         []    -> Nothing
 498         (p:_) -> Just p
 499 -----------------------------------------------------------------------------
 500 -- Ways
 501
 502 -- The central concept of a "way" is that all objects in a given
 503 -- program must be compiled in the same "way".  Certain options change
 504 -- parameters of the virtual machine, eg. profiling adds an extra word
 505 -- to the object header, so profiling objects cannot be linked with
 506 -- non-profiling objects.
 507
 508 -- After parsing the command-line options, we determine which "way" we
 509 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 510
 511 -- We then find the "build-tag" associated with this way, and this
 512 -- becomes the suffix used to find .hi files and libraries used in
 513 -- this compilation.
 514
 515 GLOBAL_VAR(build_tag, "", String)
 516
 517 data WayName
 518   = WayProf
 519   | WayUnreg
 520   | WayDll
 521   | WayTicky
 522   | WayPar
 523   | WayGran
 524   | WaySMP
 525   | WayDebug
 526   | WayUser_a
 527   | WayUser_b
 528   | WayUser_c
 529   | WayUser_d
 530   | WayUser_e
 531   | WayUser_f
 532   | WayUser_g
 533   | WayUser_h
 534   | WayUser_i
 535   | WayUser_j
 536   | WayUser_k
 537   | WayUser_l
 538   | WayUser_m
 539   | WayUser_n
 540   | WayUser_o
 541   | WayUser_A
 542   | WayUser_B
 543   deriving (Eq,Ord)
 544
 545 GLOBAL_VAR(ways, [] ,[WayName])
 546
 547 -- ToDo: allow WayDll with any other allowed combination
 548
 549 allowed_combinations =
 550    [  [WayProf,WayUnreg],
 551       [WayProf,WaySMP]     -- works???
 552    ]
 553
 554 findBuildTag :: IO [String]  -- new options
 555 findBuildTag = do
 556   way_names <- readIORef ways
 557   case sort way_names of
 558      []  -> do  writeIORef build_tag ""
 559                 return []
 560
 561      [w] -> do let details = lkupWay w
 562                writeIORef build_tag (wayTag details)
 563                return (wayOpts details)
 564
 565      ws  -> if  ws `notElem` allowed_combinations
 566                 then throwDyn (OtherError $
 567                                 "combination not supported: "  ++
 568                                 foldr1 (\a b -> a ++ '/':b)
 569                                 (map (wayName . lkupWay) ws))
 570                 else let stuff = map lkupWay ws
 571                          tag   = concat (map wayTag stuff)
 572                          flags = map wayOpts stuff
 573                      in do
 574                      writeIORef build_tag tag
 575                      return (concat flags)
 576
 577 lkupWay w =
 578    case lookup w way_details of
 579         Nothing -> error "findBuildTag"
 580         Just details -> details
 581
 582 data Way = Way {
 583   wayTag   :: String,
 584   wayName  :: String,
 585   wayOpts  :: [String]
 586   }
 587
 588 way_details :: [ (WayName, Way) ]
 589 way_details =
 590   [ (WayProf, Way  "p" "Profiling"
 591         [ "-fscc-profiling"
 592         , "-DPROFILING"
 593         , "-optc-DPROFILING"
 594         , "-fvia-C" ]),
 595
 596     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 597         [ "-fticky-ticky"
 598         , "-DTICKY_TICKY"
 599         , "-optc-DTICKY_TICKY"
 600         , "-fvia-C" ]),
 601
 602     (WayUnreg, Way  "u" "Unregisterised"
 603         [ "-optc-DNO_REGS"
 604         , "-optc-DUSE_MINIINTERPRETER"
 605         , "-fno-asm-mangling"
 606         , "-funregisterised"
 607         , "-fvia-C" ]),
 608
 609     (WayDll, Way  "dll" "DLLized"
 610         [ ]),
 611
 612     (WayPar, Way  "mp" "Parallel"
 613         [ "-fparallel"
 614         , "-D__PARALLEL_HASKELL__"
 615         , "-optc-DPAR"
 616         , "-package concurrent"
 617         , "-fvia-C" ]),
 618
 619     (WayGran, Way  "mg" "Gransim"
 620         [ "-fgransim"
 621         , "-D__GRANSIM__"
 622         , "-optc-DGRAN"
 623         , "-package concurrent"
 624         , "-fvia-C" ]),
 625
 626     (WaySMP, Way  "s" "SMP"
 627         [ "-fsmp"
 628         , "-optc-pthread"
 629         , "-optl-pthread"
 630         , "-optc-DSMP"
 631         , "-fvia-C" ]),
 632
 633     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 634     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 635     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 636     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 637     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 638     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 639     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 640     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 641     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 642     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 643     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 644     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 645     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 646     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 647     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 648     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 649     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 650   ]
 651
 652 -----------------------------------------------------------------------------
 653 -- Programs for particular phases
 654
 655 GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
 656 GLOBAL_VAR(pgm_P,   cRAWCPP,                               String)
 657 GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
 658 GLOBAL_VAR(pgm_c,   cGCC,                                  String)
 659 GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
 660 GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
 661 GLOBAL_VAR(pgm_a,   cGCC,                                  String)
 662 GLOBAL_VAR(pgm_l,   cGCC,                                  String)
 663
 664 GLOBAL_VAR(opt_dep,    [], [String])
 665 GLOBAL_VAR(anti_opt_C, [], [String])
 666 GLOBAL_VAR(opt_C,      [], [String])
 667 GLOBAL_VAR(opt_l,      [], [String])
 668 GLOBAL_VAR(opt_dll,    [], [String])
 669
 670 -----------------------------------------------------------------------------
 671 -- Via-C compilation stuff
 672
 673 -- flags returned are: ( all C compilations
 674 --                     , registerised HC compilations
 675 --                     )
 676
 677 machdepCCOpts
 678    | prefixMatch "alpha"   cTARGETPLATFORM
 679         = return ( ["-static"], [] )
 680
 681    | prefixMatch "hppa"    cTARGETPLATFORM
 682         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 683         -- (very nice, but too bad the HP /usr/include files don't agree.)
 684         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 685
 686    | prefixMatch "m68k"    cTARGETPLATFORM
 687       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 688       --    popping of args to routines to be explicit; if we let things
 689       --    be deferred 'til after an STGJUMP, imminent death is certain!
 690       --
 691       -- -fomit-frame-pointer : *don't*
 692       --     It's better to have a6 completely tied up being a frame pointer
 693       --     rather than let GCC pick random things to do with it.
 694       --     (If we want to steal a6, then we would try to do things
 695       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 696         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 697
 698    | prefixMatch "i386"    cTARGETPLATFORM
 699       -- -fno-defer-pop : basically the same game as for m68k
 700       --
 701       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 702       --   the fp (%ebp) for our register maps.
 703         = do n_regs <- readState stolen_x86_regs
 704              sta    <- readIORef static
 705              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
 706                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 707                         "-DSTOLEN_X86_REGS="++show n_regs ]
 708                     )
 709
 710    | prefixMatch "mips"    cTARGETPLATFORM
 711         = return ( ["static"], [] )
 712
 713    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 714         = return ( ["static"], ["-finhibit-size-directive"] )
 715
 716    | otherwise
 717         = return ( [], [] )
 718
 719
 720 -----------------------------------------------------------------------------
 721 -- Running an external program
 722
 723 run_something phase_name cmd
 724  = do
 725    verb <- readIORef verbose
 726    when verb $ do
 727         putStr phase_name
 728         putStrLn ":"
 729         putStrLn cmd
 730         hFlush stdout
 731
 732    -- test for -n flag
 733    n <- readIORef dry_run
 734    unless n $ do
 735
 736    -- and run it!
 737 #ifndef mingw32_TARGET_OS
 738    exit_code <- system cmd `catchAllIO`
 739                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 740 #else
 741    tmp <- newTempName "sh"
 742    h <- openFile tmp WriteMode
 743    hPutStrLn h cmd
 744    hClose h
 745    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 746                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 747    removeFile tmp
 748 #endif
 749
 750    if exit_code /= ExitSuccess
 751         then throwDyn (PhaseFailed phase_name exit_code)
 752         else do when verb (putStr "\n")
 753                 return ()
 754
 755 -----------------------------------------------------------------------------
 756 -- File suffixes & things
 757
 758 -- the output suffix for a given phase is uniquely determined by
 759 -- the input requirements of the next phase.
 760
 761 unlitInputExt       = "lhs"
 762 cppInputExt         = "lpp"
 763 hscInputExt         = "cpp"
 764 hccInputExt         = "hc"
 765 ccInputExt          = "c"
 766 mangleInputExt      = "raw_s"
 767 asInputExt          = "s"
 768 lnInputExt          = "o"