ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.15 2000/11/19 19:40:08 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 import Exception
  20 import IOExts
  21 #ifdef mingw32_TARGET_OS
  22 import TmpFiles ( newTempName )
  23 import Directory ( removeFile )
  24 #endif
  25
  26 import System
  27 import IO
  28 import List
  29 import Char
  30 import Monad
  31
  32 -----------------------------------------------------------------------------
  33 -- Driver state
  34
  35 -- certain flags can be specified on a per-file basis, in an OPTIONS
  36 -- pragma at the beginning of the source file.  This means that when
  37 -- compiling mulitple files, we have to restore the global option
  38 -- settings before compiling a new file.
  39 --
  40 -- The DriverState record contains the per-file-mutable state.
  41
  42 data DriverState = DriverState {
  43
  44         -- are we runing cpp on this file?
  45         cpp_flag                :: Bool,
  46
  47         -- misc
  48         stolen_x86_regs         :: Int,
  49         cmdline_hc_includes     :: [String],
  50
  51         -- options for a particular phase
  52         opt_L                   :: [String],
  53         opt_P                   :: [String],
  54         opt_c                   :: [String],
  55         opt_a                   :: [String],
  56         opt_m                   :: [String]
  57    }
  58
  59 initDriverState = DriverState {
  60         cpp_flag                = False,
  61         stolen_x86_regs         = 4,
  62         cmdline_hc_includes     = [],
  63         opt_L                   = [],
  64         opt_P                   = [],
  65         opt_c                   = [],
  66         opt_a                   = [],
  67         opt_m                   = [],
  68    }
  69
  70 -- The driver state is first initialized from the command line options,
  71 -- and then reset to this initial state before each compilation.
  72 -- v_InitDriverState contains the saved initial state, and v_DriverState
  73 -- contains the current state (modified by any OPTIONS pragmas, for example).
  74 --
  75 -- v_InitDriverState may also be modified from the GHCi prompt, using :set.
  76 --
  77 GLOBAL_VAR(v_InitDriverState, initDriverState, DriverState)
  78 GLOBAL_VAR(v_Driver_state,    initDriverState, DriverState)
  79
  80 readState :: (DriverState -> a) -> IO a
  81 readState f = readIORef v_Driver_state >>= return . f
  82
  83 updateState :: (DriverState -> DriverState) -> IO ()
  84 updateState f = readIORef v_Driver_state >>= writeIORef v_Driver_state . f
  85
  86 addOpt_L     a = updateState (\s -> s{opt_L =  a : opt_L s})
  87 addOpt_P     a = updateState (\s -> s{opt_P =  a : opt_P s})
  88 addOpt_c     a = updateState (\s -> s{opt_c =  a : opt_c s})
  89 addOpt_a     a = updateState (\s -> s{opt_a =  a : opt_a s})
  90 addOpt_m     a = updateState (\s -> s{opt_m =  a : opt_m s})
  91
  92 addCmdlineHCInclude a =
  93    updateState (\s -> s{cmdline_hc_includes =  a : cmdline_hc_includes s})
  94
  95         -- we add to the options from the front, so we need to reverse the list
  96 getOpts :: (DriverState -> [a]) -> IO [a]
  97 getOpts opts = readState opts >>= return . reverse
  98
  99 -----------------------------------------------------------------------------
 100 -- non-configured things
 101
 102 cHaskell1Version = "5" -- i.e., Haskell 98
 103
 104 -----------------------------------------------------------------------------
 105 -- Global compilation flags
 106
 107 -- location of compiler-related files
 108 GLOBAL_VAR(v_TopDir,  clibdir, String)
 109
 110 -- Cpp-related flags
 111 v_Hs_source_cpp_opts = global
 112         [ "-D__HASKELL1__="++cHaskell1Version
 113         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
 114         , "-D__HASKELL98__"
 115         , "-D__CONCURRENT_HASKELL__"
 116         ]
 117 {-# NOINLINE v_Hs_source_cpp_opts #-}
 118
 119 -- Verbose
 120 GLOBAL_VAR(v_Verbose, False, Bool)
 121 is_verbose = do v <- readIORef v_Verbose; if v then return "-v" else return ""
 122
 123 -- Keep output from intermediate phases
 124 GLOBAL_VAR(v_Keep_hi_diffs,             False,          Bool)
 125 GLOBAL_VAR(v_Keep_hc_files,             False,          Bool)
 126 GLOBAL_VAR(v_Keep_s_files,              False,          Bool)
 127 GLOBAL_VAR(v_Keep_raw_s_files,          False,          Bool)
 128 GLOBAL_VAR(v_Keep_tmp_files,            False,          Bool)
 129
 130 -- Misc
 131 GLOBAL_VAR(v_Scale_sizes_by,            1.0,            Double)
 132 GLOBAL_VAR(v_Dry_run,                   False,          Bool)
 133 #if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
 134 GLOBAL_VAR(v_Static,                    True,           Bool)
 135 #else
 136 GLOBAL_VAR(v_Static,                    False,          Bool)
 137 #endif
 138 GLOBAL_VAR(v_NoHsMain,                  False,          Bool)
 139 GLOBAL_VAR(v_Recomp,                    True,           Bool)
 140 GLOBAL_VAR(v_Collect_ghc_timing,        False,          Bool)
 141 GLOBAL_VAR(v_Do_asm_mangling,           True,           Bool)
 142 GLOBAL_VAR(v_Excess_precision,          False,          Bool)
 143
 144 -----------------------------------------------------------------------------
 145 -- Splitting object files (for libraries)
 146
 147 GLOBAL_VAR(v_Split_object_files,        False,          Bool)
 148 GLOBAL_VAR(v_Split_prefix,              "",             String)
 149 GLOBAL_VAR(v_N_split_files,             0,              Int)
 150
 151 can_split :: Bool
 152 can_split =  prefixMatch "i386"    cTARGETPLATFORM
 153           || prefixMatch "alpha"   cTARGETPLATFORM
 154           || prefixMatch "hppa"    cTARGETPLATFORM
 155           || prefixMatch "m68k"    cTARGETPLATFORM
 156           || prefixMatch "mips"    cTARGETPLATFORM
 157           || prefixMatch "powerpc" cTARGETPLATFORM
 158           || prefixMatch "rs6000"  cTARGETPLATFORM
 159           || prefixMatch "sparc"   cTARGETPLATFORM
 160
 161 -----------------------------------------------------------------------------
 162 -- Compiler output options
 163
 164 defaultHscLang
 165   | cGhcWithNativeCodeGen == "YES" &&
 166         (prefixMatch "i386" cTARGETPLATFORM ||
 167          prefixMatch "sparc" cTARGETPLATFORM)   =  HscAsm
 168   | otherwise                                   =  HscC
 169
 170 GLOBAL_VAR(v_Output_dir,  Nothing, Maybe String)
 171 GLOBAL_VAR(v_Object_suf,  Nothing, Maybe String)
 172 GLOBAL_VAR(v_Output_file, Nothing, Maybe String)
 173 GLOBAL_VAR(v_Output_hi,   Nothing, Maybe String)
 174
 175 GLOBAL_VAR(v_Ld_inputs, [],      [String])
 176
 177 odir_ify :: String -> IO String
 178 odir_ify f = do
 179   odir_opt <- readIORef v_Output_dir
 180   case odir_opt of
 181         Nothing -> return f
 182         Just d  -> return (newdir d f)
 183
 184 osuf_ify :: String -> IO String
 185 osuf_ify f = do
 186   osuf_opt <- readIORef v_Object_suf
 187   case osuf_opt of
 188         Nothing -> return f
 189         Just s  -> return (newsuf s f)
 190
 191 -----------------------------------------------------------------------------
 192 -- Hi Files
 193
 194 GLOBAL_VAR(v_ProduceHi,         True,   Bool)
 195 GLOBAL_VAR(v_Hi_on_stdout,      False,  Bool)
 196 GLOBAL_VAR(v_Hi_suf,            "hi",   String)
 197
 198 -----------------------------------------------------------------------------
 199 -- Warnings & sanity checking
 200
 201 -- Warning packages that are controlled by -W and -Wall.  The 'standard'
 202 -- warnings that you get all the time are
 203 --
 204 --         -fwarn-overlapping-patterns
 205 --         -fwarn-missing-methods
 206 --         -fwarn-missing-fields
 207 --         -fwarn-deprecations
 208 --         -fwarn-duplicate-exports
 209 --
 210 -- these are turned off by -Wnot.
 211
 212
 213 standardWarnings  = [ "-fwarn-overlapping-patterns"
 214                     , "-fwarn-missing-methods"
 215                     , "-fwarn-missing-fields"
 216                     , "-fwarn-deprecations"
 217                     , "-fwarn-duplicate-exports"
 218                     ]
 219 minusWOpts        = standardWarnings ++
 220                     [ "-fwarn-unused-binds"
 221                     , "-fwarn-unused-matches"
 222                     , "-fwarn-incomplete-patterns"
 223                     , "-fwarn-unused-imports"
 224                     ]
 225 minusWallOpts     = minusWOpts ++
 226                     [ "-fwarn-type-defaults"
 227                     , "-fwarn-name-shadowing"
 228                     , "-fwarn-missing-signatures"
 229                     , "-fwarn-hi-shadowing"
 230                     ]
 231
 232 data WarningState = W_default | W_ | W_all | W_not
 233 GLOBAL_VAR(v_Warning_opt, W_default, WarningState)
 234
 235 -----------------------------------------------------------------------------
 236 -- Compiler optimisation options
 237
 238 GLOBAL_VAR(v_OptLevel, 0, Int)
 239
 240 setOptLevel :: String -> IO ()
 241 setOptLevel ""              = do { writeIORef v_OptLevel 1 }
 242 setOptLevel "not"           = writeIORef v_OptLevel 0
 243 setOptLevel [c] | isDigit c = do
 244    let level = ord c - ord '0'
 245    writeIORef v_OptLevel level
 246 setOptLevel s = unknownFlagErr ("-O"++s)
 247
 248 GLOBAL_VAR(v_minus_o2_for_C,            False, Bool)
 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 getStaticOptimisationFlags 0 = hsc_minusNoO_flags
 275 getStaticOptimisationFlags 1 = hsc_minusO_flags
 276 getStaticOptimisationFlags n = hsc_minusO2_flags
 277
 278 buildCoreToDo :: IO [CoreToDo]
 279 buildCoreToDo = do
 280    opt_level  <- readIORef v_OptLevel
 281    max_iter   <- readIORef v_MaxSimplifierIterations
 282    usageSP    <- readIORef v_UsageSPInf
 283    strictness <- readIORef v_Strictness
 284    cpr        <- readIORef v_CPR
 285    cse        <- readIORef v_CSE
 286
 287    if opt_level == 0 then return
 288       [
 289         CoreDoSimplify (isAmongSimpl [
 290             MaxSimplifierIterations max_iter
 291         ])
 292       ]
 293
 294     else {- level >= 1 -} return [
 295
 296         -- initial simplify: mk specialiser happy: minimum effort please
 297         CoreDoSimplify (isAmongSimpl [
 298             SimplInlinePhase 0,
 299                         -- Don't inline anything till full laziness has bitten
 300                         -- In particular, inlining wrappers inhibits floating
 301                         -- e.g. ...(case f x of ...)...
 302                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
 303                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
 304                         -- and now the redex (f x) isn't floatable any more
 305             DontApplyRules,
 306                         -- Similarly, don't apply any rules until after full
 307                         -- laziness.  Notably, list fusion can prevent floating.
 308             NoCaseOfCase,
 309                         -- Don't do case-of-case transformations.
 310                         -- This makes full laziness work better
 311             MaxSimplifierIterations max_iter
 312         ]),
 313
 314         -- Specialisation is best done before full laziness
 315         -- so that overloaded functions have all their dictionary lambdas manifest
 316         CoreDoSpecialising,
 317
 318         CoreDoFloatOutwards False{-not full-},
 319         CoreDoFloatInwards,
 320
 321         CoreDoSimplify (isAmongSimpl [
 322            SimplInlinePhase 1,
 323                 -- Want to run with inline phase 1 after the specialiser to give
 324                 -- maximum chance for fusion to work before we inline build/augment
 325                 -- in phase 2.  This made a difference in 'ansi' where an
 326                 -- overloaded function wasn't inlined till too late.
 327            MaxSimplifierIterations max_iter
 328         ]),
 329
 330         -- infer usage information here in case we need it later.
 331         -- (add more of these where you need them --KSW 1999-04)
 332         if usageSP then CoreDoUSPInf else CoreDoNothing,
 333
 334         CoreDoSimplify (isAmongSimpl [
 335                 -- Need inline-phase2 here so that build/augment get
 336                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 337                 -- strictness in the function sumcode' if augment is not inlined
 338                 -- before strictness analysis runs
 339            SimplInlinePhase 2,
 340            MaxSimplifierIterations max_iter
 341         ]),
 342
 343         CoreDoSimplify (isAmongSimpl [
 344            MaxSimplifierIterations 2
 345                 -- No -finline-phase: allow all Ids to be inlined now
 346                 -- This gets foldr inlined before strictness analysis
 347         ]),
 348
 349         if strictness then CoreDoStrictness else CoreDoNothing,
 350         if cpr        then CoreDoCPResult   else CoreDoNothing,
 351         CoreDoWorkerWrapper,
 352         CoreDoGlomBinds,
 353
 354         CoreDoSimplify (isAmongSimpl [
 355            MaxSimplifierIterations max_iter
 356                 -- No -finline-phase: allow all Ids to be inlined now
 357         ]),
 358
 359         CoreDoFloatOutwards False{-not full-},
 360                 -- nofib/spectral/hartel/wang doubles in speed if you
 361                 -- do full laziness late in the day.  It only happens
 362                 -- after fusion and other stuff, so the early pass doesn't
 363                 -- catch it.  For the record, the redex is
 364                 --        f_el22 (f_el21 r_midblock)
 365
 366 -- Leave out lambda lifting for now
 367 --        "-fsimplify", -- Tidy up results of full laziness
 368 --          "[",
 369 --                "-fmax-simplifier-iterations2",
 370 --          "]",
 371 --        "-ffloat-outwards-full",
 372
 373         -- We want CSE to follow the final full-laziness pass, because it may
 374         -- succeed in commoning up things floated out by full laziness.
 375         --
 376         -- CSE must immediately follow a simplification pass, because it relies
 377         -- on the no-shadowing invariant.  See comments at the top of CSE.lhs
 378         -- So it must NOT follow float-inwards, which can give rise to shadowing,
 379         -- even if its input doesn't have shadows.  Hence putting it between
 380         -- the two passes.
 381         if cse then CoreCSE else CoreDoNothing,
 382
 383         CoreDoFloatInwards,
 384
 385 -- Case-liberation for -O2.  This should be after
 386 -- strictness analysis and the simplification which follows it.
 387
 388 --        ( ($OptLevel != 2)
 389 --        ? ""
 390 --        : "-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 ]" ),
 391 --
 392 --        "-fliberate-case",
 393
 394         -- Final clean-up simplification:
 395         CoreDoSimplify (isAmongSimpl [
 396           MaxSimplifierIterations max_iter
 397                 -- No -finline-phase: allow all Ids to be inlined now
 398         ])
 399      ]
 400
 401 buildStgToDo :: IO [ StgToDo ]
 402 buildStgToDo = do
 403   stg_stats <- readIORef v_StgStats
 404   let flags1 | stg_stats = [ D_stg_stats ]
 405              | otherwise = [ ]
 406
 407         -- STG passes
 408   ways_ <- readIORef v_Ways
 409   let flags2 | WayProf `elem` ways_ = StgDoMassageForProfiling : flags1
 410              | otherwise            = flags1
 411
 412   return flags2
 413
 414 -----------------------------------------------------------------------------
 415 -- Paths & Libraries
 416
 417 split_marker = ':'   -- not configurable (ToDo)
 418
 419 v_Import_paths, v_Include_paths, v_Library_paths :: IORef [String]
 420 GLOBAL_VAR(v_Import_paths,  ["."], [String])
 421 GLOBAL_VAR(v_Include_paths, ["."], [String])
 422 GLOBAL_VAR(v_Library_paths, [],  [String])
 423
 424 GLOBAL_VAR(v_Cmdline_libraries,   [], [String])
 425
 426 addToDirList :: IORef [String] -> String -> IO ()
 427 addToDirList ref path
 428   = do paths <- readIORef ref
 429        writeIORef ref (paths ++ split split_marker path)
 430
 431 -----------------------------------------------------------------------------
 432 -- Packages
 433
 434 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
 435
 436 -- package list is maintained in dependency order
 437 GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String])
 438
 439 addPackage :: String -> IO ()
 440 addPackage package
 441   = do pkg_details <- readIORef v_Package_details
 442        case lookupPkg package pkg_details of
 443           Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
 444           Just details -> do
 445             ps <- readIORef v_Packages
 446             unless (package `elem` ps) $ do
 447                 mapM_ addPackage (package_deps details)
 448                 ps <- readIORef v_Packages
 449                 writeIORef v_Packages (package:ps)
 450
 451 getPackageImportPath   :: IO [String]
 452 getPackageImportPath = do
 453   ps <- getPackageInfo
 454   return (nub (concat (map import_dirs ps)))
 455
 456 getPackageIncludePath   :: IO [String]
 457 getPackageIncludePath = do
 458   ps <- getPackageInfo
 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 <- getPackageInfo
 465   return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
 466
 467 getPackageLibraryPath  :: IO [String]
 468 getPackageLibraryPath = do
 469   ps <- getPackageInfo
 470   return (nub (concat (map library_dirs ps)))
 471
 472 getPackageLibraries    :: IO [String]
 473 getPackageLibraries = do
 474   ps <- getPackageInfo
 475   tag <- readIORef v_Build_tag
 476   let suffix = if null tag then "" else '_':tag
 477   return (concat (
 478         map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps
 479      ))
 480
 481 getPackageExtraGhcOpts :: IO [String]
 482 getPackageExtraGhcOpts = do
 483   ps <- getPackageInfo
 484   return (concatMap extra_ghc_opts ps)
 485
 486 getPackageExtraCcOpts  :: IO [String]
 487 getPackageExtraCcOpts = do
 488   ps <- getPackageInfo
 489   return (concatMap extra_cc_opts ps)
 490
 491 getPackageExtraLdOpts  :: IO [String]
 492 getPackageExtraLdOpts = do
 493   ps <- getPackageInfo
 494   return (concatMap extra_ld_opts ps)
 495
 496 getPackageInfo :: IO [Package]
 497 getPackageInfo = do
 498   ps <- readIORef v_Packages
 499   getPackageDetails ps
 500
 501 getPackageDetails :: [String] -> IO [Package]
 502 getPackageDetails ps = do
 503   pkg_details <- readIORef v_Package_details
 504   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 505
 506 GLOBAL_VAR(v_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(v_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(v_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 v_Ways
 571   case sort way_names of
 572      []  -> do  writeIORef v_Build_tag ""
 573                 return []
 574
 575      [w] -> do let details = lkupWay w
 576                writeIORef v_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 v_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(v_Pgm_L,   error "pgm_L", String)
 670 GLOBAL_VAR(v_Pgm_P,   cRAWCPP,       String)
 671 GLOBAL_VAR(v_Pgm_c,   cGCC,          String)
 672 GLOBAL_VAR(v_Pgm_m,   error "pgm_m", String)
 673 GLOBAL_VAR(v_Pgm_s,   error "pgm_s", String)
 674 GLOBAL_VAR(v_Pgm_a,   cGCC,          String)
 675 GLOBAL_VAR(v_Pgm_l,   cGCC,          String)
 676
 677 GLOBAL_VAR(v_Opt_dep,    [], [String])
 678 GLOBAL_VAR(v_Anti_opt_C, [], [String])
 679 GLOBAL_VAR(v_Opt_C,      [], [String])
 680 GLOBAL_VAR(v_Opt_l,      [], [String])
 681 GLOBAL_VAR(v_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 v_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 v_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 v_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