ghc/compiler/main/DriverState.hs

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