ghc/compiler/main/DriverState.hs

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