ghc/compiler/main/DriverState.hs

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