ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.6 2000/10/24 16:08:16 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 buildStgToDo :: IO [ StgToDo ]
 397 buildStgToDo = do
 398   stg_stats <- readIORef v_StgStats
 399   let flags1 | stg_stats = [ D_stg_stats ]
 400              | otherwise = [ ]
 401
 402         -- STG passes
 403   ways_ <- readIORef ways
 404   let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
 405              | otherwise            = flags1
 406
 407   return flags2
 408
 409 -----------------------------------------------------------------------------
 410 -- Paths & Libraries
 411
 412 split_marker = ':'   -- not configurable (ToDo)
 413
 414 import_paths, include_paths, library_paths :: IORef [String]
 415 GLOBAL_VAR(import_paths,  ["."], [String])
 416 GLOBAL_VAR(include_paths, ["."], [String])
 417 GLOBAL_VAR(library_paths, [],    [String])
 418
 419 GLOBAL_VAR(cmdline_libraries,   [], [String])
 420
 421 addToDirList :: IORef [String] -> String -> IO ()
 422 addToDirList ref path
 423   = do paths <- readIORef ref
 424        writeIORef ref (paths ++ split split_marker path)
 425
 426 -----------------------------------------------------------------------------
 427 -- Packages
 428
 429 GLOBAL_VAR(path_package_config, error "path_package_config", String)
 430
 431 -- package list is maintained in dependency order
 432 packages = global ["std", "rts", "gmp"] :: IORef [String]
 433 -- comma in value, so can't use macro, grrr
 434 {-# NOINLINE packages #-}
 435
 436 addPackage :: String -> IO ()
 437 addPackage package
 438   = do pkg_details <- readIORef package_details
 439        case lookupPkg package pkg_details of
 440           Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
 441           Just details -> do
 442             ps <- readIORef packages
 443             unless (package `elem` ps) $ do
 444                 mapM_ addPackage (package_deps details)
 445                 ps <- readIORef packages
 446                 writeIORef packages (package:ps)
 447
 448 getPackageImportPath   :: IO [String]
 449 getPackageImportPath = do
 450   ps <- readIORef packages
 451   ps' <- getPackageDetails ps
 452   return (nub (concat (map import_dirs ps')))
 453
 454 getPackageIncludePath   :: IO [String]
 455 getPackageIncludePath = do
 456   ps <- readIORef packages
 457   ps' <- getPackageDetails ps
 458   return (nub (filter (not.null) (concatMap include_dirs ps')))
 459
 460         -- includes are in reverse dependency order (i.e. rts first)
 461 getPackageCIncludes   :: IO [String]
 462 getPackageCIncludes = do
 463   ps <- readIORef packages
 464   ps' <- getPackageDetails ps
 465   return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
 466
 467 getPackageLibraryPath  :: IO [String]
 468 getPackageLibraryPath = do
 469   ps <- readIORef packages
 470   ps' <- getPackageDetails ps
 471   return (nub (concat (map library_dirs ps')))
 472
 473 getPackageLibraries    :: IO [String]
 474 getPackageLibraries = do
 475   ps <- readIORef packages
 476   ps' <- getPackageDetails ps
 477   tag <- readIORef build_tag
 478   let suffix = if null tag then "" else '_':tag
 479   return (concat (
 480         map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
 481      ))
 482
 483 getPackageExtraGhcOpts :: IO [String]
 484 getPackageExtraGhcOpts = do
 485   ps <- readIORef packages
 486   ps' <- getPackageDetails ps
 487   return (concatMap extra_ghc_opts ps')
 488
 489 getPackageExtraCcOpts  :: IO [String]
 490 getPackageExtraCcOpts = do
 491   ps <- readIORef packages
 492   ps' <- getPackageDetails ps
 493   return (concatMap extra_cc_opts ps')
 494
 495 getPackageExtraLdOpts  :: IO [String]
 496 getPackageExtraLdOpts = do
 497   ps <- readIORef packages
 498   ps' <- getPackageDetails ps
 499   return (concatMap extra_ld_opts ps')
 500
 501 getPackageDetails :: [String] -> IO [Package]
 502 getPackageDetails ps = do
 503   pkg_details <- readIORef package_details
 504   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 505
 506 GLOBAL_VAR(package_details, (error "package_details"), [Package])
 507
 508 lookupPkg :: String -> [Package] -> Maybe Package
 509 lookupPkg nm ps
 510    = case [p | p <- ps, name p == nm] of
 511         []    -> Nothing
 512         (p:_) -> Just p
 513 -----------------------------------------------------------------------------
 514 -- Ways
 515
 516 -- The central concept of a "way" is that all objects in a given
 517 -- program must be compiled in the same "way".  Certain options change
 518 -- parameters of the virtual machine, eg. profiling adds an extra word
 519 -- to the object header, so profiling objects cannot be linked with
 520 -- non-profiling objects.
 521
 522 -- After parsing the command-line options, we determine which "way" we
 523 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 524
 525 -- We then find the "build-tag" associated with this way, and this
 526 -- becomes the suffix used to find .hi files and libraries used in
 527 -- this compilation.
 528
 529 GLOBAL_VAR(build_tag, "", String)
 530
 531 data WayName
 532   = WayProf
 533   | WayUnreg
 534   | WayDll
 535   | WayTicky
 536   | WayPar
 537   | WayGran
 538   | WaySMP
 539   | WayDebug
 540   | WayUser_a
 541   | WayUser_b
 542   | WayUser_c
 543   | WayUser_d
 544   | WayUser_e
 545   | WayUser_f
 546   | WayUser_g
 547   | WayUser_h
 548   | WayUser_i
 549   | WayUser_j
 550   | WayUser_k
 551   | WayUser_l
 552   | WayUser_m
 553   | WayUser_n
 554   | WayUser_o
 555   | WayUser_A
 556   | WayUser_B
 557   deriving (Eq,Ord)
 558
 559 GLOBAL_VAR(ways, [] ,[WayName])
 560
 561 -- ToDo: allow WayDll with any other allowed combination
 562
 563 allowed_combinations =
 564    [  [WayProf,WayUnreg],
 565       [WayProf,WaySMP]     -- works???
 566    ]
 567
 568 findBuildTag :: IO [String]  -- new options
 569 findBuildTag = do
 570   way_names <- readIORef ways
 571   case sort way_names of
 572      []  -> do  writeIORef build_tag ""
 573                 return []
 574
 575      [w] -> do let details = lkupWay w
 576                writeIORef build_tag (wayTag details)
 577                return (wayOpts details)
 578
 579      ws  -> if  ws `notElem` allowed_combinations
 580                 then throwDyn (OtherError $
 581                                 "combination not supported: "  ++
 582                                 foldr1 (\a b -> a ++ '/':b)
 583                                 (map (wayName . lkupWay) ws))
 584                 else let stuff = map lkupWay ws
 585                          tag   = concat (map wayTag stuff)
 586                          flags = map wayOpts stuff
 587                      in do
 588                      writeIORef build_tag tag
 589                      return (concat flags)
 590
 591 lkupWay w =
 592    case lookup w way_details of
 593         Nothing -> error "findBuildTag"
 594         Just details -> details
 595
 596 data Way = Way {
 597   wayTag   :: String,
 598   wayName  :: String,
 599   wayOpts  :: [String]
 600   }
 601
 602 way_details :: [ (WayName, Way) ]
 603 way_details =
 604   [ (WayProf, Way  "p" "Profiling"
 605         [ "-fscc-profiling"
 606         , "-DPROFILING"
 607         , "-optc-DPROFILING"
 608         , "-fvia-C" ]),
 609
 610     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 611         [ "-fticky-ticky"
 612         , "-DTICKY_TICKY"
 613         , "-optc-DTICKY_TICKY"
 614         , "-fvia-C" ]),
 615
 616     (WayUnreg, Way  "u" "Unregisterised"
 617         [ "-optc-DNO_REGS"
 618         , "-optc-DUSE_MINIINTERPRETER"
 619         , "-fno-asm-mangling"
 620         , "-funregisterised"
 621         , "-fvia-C" ]),
 622
 623     (WayDll, Way  "dll" "DLLized"
 624         [ ]),
 625
 626     (WayPar, Way  "mp" "Parallel"
 627         [ "-fparallel"
 628         , "-D__PARALLEL_HASKELL__"
 629         , "-optc-DPAR"
 630         , "-package concurrent"
 631         , "-fvia-C" ]),
 632
 633     (WayGran, Way  "mg" "Gransim"
 634         [ "-fgransim"
 635         , "-D__GRANSIM__"
 636         , "-optc-DGRAN"
 637         , "-package concurrent"
 638         , "-fvia-C" ]),
 639
 640     (WaySMP, Way  "s" "SMP"
 641         [ "-fsmp"
 642         , "-optc-pthread"
 643         , "-optl-pthread"
 644         , "-optc-DSMP"
 645         , "-fvia-C" ]),
 646
 647     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 648     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 649     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 650     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 651     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 652     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 653     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 654     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 655     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 656     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 657     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 658     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 659     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 660     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 661     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 662     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 663     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 664   ]
 665
 666 -----------------------------------------------------------------------------
 667 -- Programs for particular phases
 668
 669 GLOBAL_VAR(pgm_L,   error "pgm_L", String)
 670 GLOBAL_VAR(pgm_P,   cRAWCPP,       String)
 671 GLOBAL_VAR(pgm_c,   cGCC,          String)
 672 GLOBAL_VAR(pgm_m,   error "pgm_m", String)
 673 GLOBAL_VAR(pgm_s,   error "pgm_s", String)
 674 GLOBAL_VAR(pgm_a,   cGCC,          String)
 675 GLOBAL_VAR(pgm_l,   cGCC,          String)
 676
 677 GLOBAL_VAR(opt_dep,    [], [String])
 678 GLOBAL_VAR(anti_opt_C, [], [String])
 679 GLOBAL_VAR(opt_C,      [], [String])
 680 GLOBAL_VAR(opt_l,      [], [String])
 681 GLOBAL_VAR(opt_dll,    [], [String])
 682
 683 getStaticOpts :: IORef [String] -> IO [String]
 684 getStaticOpts ref = readIORef ref >>= return . reverse
 685
 686 -----------------------------------------------------------------------------
 687 -- Via-C compilation stuff
 688
 689 -- flags returned are: ( all C compilations
 690 --                     , registerised HC compilations
 691 --                     )
 692
 693 machdepCCOpts
 694    | prefixMatch "alpha"   cTARGETPLATFORM
 695         = return ( ["-static"], [] )
 696
 697    | prefixMatch "hppa"    cTARGETPLATFORM
 698         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 699         -- (very nice, but too bad the HP /usr/include files don't agree.)
 700         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 701
 702    | prefixMatch "m68k"    cTARGETPLATFORM
 703       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 704       --    popping of args to routines to be explicit; if we let things
 705       --    be deferred 'til after an STGJUMP, imminent death is certain!
 706       --
 707       -- -fomit-frame-pointer : *don't*
 708       --     It's better to have a6 completely tied up being a frame pointer
 709       --     rather than let GCC pick random things to do with it.
 710       --     (If we want to steal a6, then we would try to do things
 711       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 712         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 713
 714    | prefixMatch "i386"    cTARGETPLATFORM
 715       -- -fno-defer-pop : basically the same game as for m68k
 716       --
 717       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 718       --   the fp (%ebp) for our register maps.
 719         = do n_regs <- readState stolen_x86_regs
 720              sta    <- readIORef static
 721              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
 722                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 723                         "-DSTOLEN_X86_REGS="++show n_regs ]
 724                     )
 725
 726    | prefixMatch "mips"    cTARGETPLATFORM
 727         = return ( ["static"], [] )
 728
 729    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 730         = return ( ["static"], ["-finhibit-size-directive"] )
 731
 732    | otherwise
 733         = return ( [], [] )
 734
 735
 736 -----------------------------------------------------------------------------
 737 -- Running an external program
 738
 739 run_something phase_name cmd
 740  = do
 741    verb <- readIORef verbose
 742    when verb $ do
 743         putStr phase_name
 744         putStrLn ":"
 745         putStrLn cmd
 746         hFlush stdout
 747
 748    -- test for -n flag
 749    n <- readIORef dry_run
 750    unless n $ do
 751
 752    -- and run it!
 753 #ifndef mingw32_TARGET_OS
 754    exit_code <- system cmd `catchAllIO`
 755                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 756 #else
 757    tmp <- newTempName "sh"
 758    h <- openFile tmp WriteMode
 759    hPutStrLn h cmd
 760    hClose h
 761    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 762                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 763    removeFile tmp
 764 #endif
 765
 766    if exit_code /= ExitSuccess
 767         then throwDyn (PhaseFailed phase_name exit_code)
 768         else do when verb (putStr "\n")
 769                 return ()
 770