ghc/compiler/main/DriverState.hs

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