ghc/compiler/main/DriverState.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: DriverState.hs,v 1.2 2000/10/11 14:08:52 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 Array
  20
  21 import Exception
  22 import IOExts
  23
  24 import System
  25 import IO
  26 import List
  27 import Char
  28 import Monad
  29
  30 -----------------------------------------------------------------------------
  31 -- Driver state
  32
  33 -- certain flags can be specified on a per-file basis, in an OPTIONS
  34 -- pragma at the beginning of the source file.  This means that when
  35 -- compiling mulitple files, we have to restore the global option
  36 -- settings before compiling a new file.
  37 --
  38 -- The DriverState record contains the per-file-mutable state.
  39
  40 data DriverState = DriverState {
  41
  42         -- are we runing cpp on this file?
  43         cpp_flag                :: Bool,
  44
  45         -- misc
  46         stolen_x86_regs         :: Int,
  47         cmdline_hc_includes     :: [String],
  48
  49         -- options for a particular phase
  50         opt_L                   :: [String],
  51         opt_P                   :: [String],
  52         opt_c                   :: [String],
  53         opt_a                   :: [String],
  54         opt_m                   :: [String]
  55    }
  56
  57 initDriverState = DriverState {
  58         cpp_flag                = False,
  59         stolen_x86_regs         = 4,
  60         cmdline_hc_includes     = [],
  61         opt_L                   = [],
  62         opt_P                   = [],
  63         opt_c                   = [],
  64         opt_a                   = [],
  65         opt_m                   = [],
  66    }
  67
  68 GLOBAL_VAR(driver_state, initDriverState, DriverState)
  69
  70 readState :: (DriverState -> a) -> IO a
  71 readState f = readIORef driver_state >>= return . f
  72
  73 updateState :: (DriverState -> DriverState) -> IO ()
  74 updateState f = readIORef driver_state >>= writeIORef driver_state . f
  75
  76 addOpt_L     a = updateState (\s -> s{opt_L      =  a : opt_L      s})
  77 addOpt_P     a = updateState (\s -> s{opt_P      =  a : opt_P      s})
  78 addOpt_c     a = updateState (\s -> s{opt_c      =  a : opt_c      s})
  79 addOpt_a     a = updateState (\s -> s{opt_a      =  a : opt_a      s})
  80 addOpt_m     a = updateState (\s -> s{opt_m      =  a : opt_m      s})
  81
  82 addCmdlineHCInclude a =
  83    updateState (\s -> s{cmdline_hc_includes =  a : cmdline_hc_includes s})
  84
  85         -- we add to the options from the front, so we need to reverse the list
  86 getOpts :: (DriverState -> [a]) -> IO [a]
  87 getOpts opts = readState opts >>= return . reverse
  88
  89 -----------------------------------------------------------------------------
  90 -- non-configured things
  91
  92 cHaskell1Version = "5" -- i.e., Haskell 98
  93
  94 -----------------------------------------------------------------------------
  95 -- Global compilation flags
  96
  97 -- location of compiler-related files
  98 GLOBAL_VAR(topDir,  clibdir, String)
  99 GLOBAL_VAR(inplace, False,   Bool)
 100
 101 -- Cpp-related flags
 102 hs_source_cpp_opts = global
 103         [ "-D__HASKELL1__="++cHaskell1Version
 104         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
 105         , "-D__HASKELL98__"
 106         , "-D__CONCURRENT_HASKELL__"
 107         ]
 108
 109 -- Verbose
 110 GLOBAL_VAR(verbose, False, Bool)
 111 is_verbose = do v <- readIORef 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(keep_hi_diffs,       False,          Bool)
 118 GLOBAL_VAR(keep_hc_files,       False,          Bool)
 119 GLOBAL_VAR(keep_s_files,        False,          Bool)
 120 GLOBAL_VAR(keep_raw_s_files,    False,          Bool)
 121 GLOBAL_VAR(keep_tmp_files,      False,          Bool)
 122
 123 -- Misc
 124 GLOBAL_VAR(scale_sizes_by,      1.0,            Double)
 125 GLOBAL_VAR(dry_run,             False,          Bool)
 126 #if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
 127 GLOBAL_VAR(static,              True,           Bool)
 128 #else
 129 GLOBAL_VAR(static,              False,          Bool)
 130 #endif
 131 GLOBAL_VAR(recomp,              True,           Bool)
 132 GLOBAL_VAR(collect_ghc_timing,  False,          Bool)
 133 GLOBAL_VAR(do_asm_mangling,     True,           Bool)
 134 GLOBAL_VAR(excess_precision,    False,          Bool)
 135
 136 -----------------------------------------------------------------------------
 137 -- Splitting object files (for libraries)
 138
 139 GLOBAL_VAR(split_object_files,  False,          Bool)
 140 GLOBAL_VAR(split_prefix,        "",             String)
 141 GLOBAL_VAR(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(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(output_dir,  Nothing, Maybe String)
 164 GLOBAL_VAR(output_suf,  Nothing, Maybe String)
 165 GLOBAL_VAR(output_file, Nothing, Maybe String)
 166 GLOBAL_VAR(output_hi,   Nothing, Maybe String)
 167
 168 GLOBAL_VAR(ld_inputs,   [],      [String])
 169
 170 odir_ify :: String -> IO String
 171 odir_ify f = do
 172   odir_opt <- readIORef 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 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(produceHi,           True,   Bool)
 188 GLOBAL_VAR(hi_on_stdout,        False,  Bool)
 189 GLOBAL_VAR(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(warning_opt, W_default, WarningState)
 227
 228 -----------------------------------------------------------------------------
 229 -- Compiler optimisation options
 230
 231 GLOBAL_VAR(opt_level, 0, Int)
 232
 233 setOptLevel :: String -> IO ()
 234 setOptLevel ""              = do { writeIORef opt_level 1; go_via_C }
 235 setOptLevel "not"           = writeIORef opt_level 0
 236 setOptLevel [c] | isDigit c = do
 237    let level = ord c - ord '0'
 238    writeIORef opt_level level
 239    when (level >= 1) go_via_C
 240 setOptLevel s = unknownFlagErr ("-O"++s)
 241
 242 go_via_C = do
 243    l <- readIORef hsc_lang
 244    case l of { HscAsm -> writeIORef hsc_lang HscC;
 245                _other -> return () }
 246
 247 GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
 248
 249 GLOBAL_VAR(opt_MaxSimplifierIterations, 4,     Int)
 250 GLOBAL_VAR(opt_StgStats,                False, Bool)
 251 GLOBAL_VAR(opt_UsageSPInf,              False, Bool)  -- Off by default
 252 GLOBAL_VAR(opt_Strictness,              True,  Bool)
 253 GLOBAL_VAR(opt_CPR,                     True,  Bool)
 254
 255 hsc_minusO2_flags = hsc_minusO_flags    -- for now
 256
 257 hsc_minusNoO_flags = do
 258   iter        <- readIORef opt_MaxSimplifierIterations
 259   return [
 260         "-fignore-interface-pragmas",
 261         "-fomit-interface-pragmas"
 262         ]
 263
 264 hsc_minusO_flags = do
 265   stgstats   <- readIORef opt_StgStats
 266
 267   return [
 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 build_CoreToDo
 277    :: Int       -- opt level
 278    -> Int       -- max iterations
 279    -> Bool      -- do usageSP
 280    -> Bool      -- do strictness
 281    -> Bool      -- do CPR
 282    -> Bool      -- do CSE
 283    -> [CoreToDo]
 284
 285 build_CoreToDo level max_iter usageSP strictness cpr cse
 286   | level == 0 = [
 287         CoreDoSimplify (isAmongSimpl [
 288             MaxSimplifierIterations max_iter
 289         ])
 290       ]
 291
 292   | level >= 1 = [
 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 -----------------------------------------------------------------------------
 400 -- Paths & Libraries
 401
 402 split_marker = ':'   -- not configurable (ToDo)
 403
 404 import_paths, include_paths, library_paths :: IORef [String]
 405 GLOBAL_VAR(import_paths,  ["."], [String])
 406 GLOBAL_VAR(include_paths, ["."], [String])
 407 GLOBAL_VAR(library_paths, [],    [String])
 408
 409 GLOBAL_VAR(cmdline_libraries,   [], [String])
 410
 411 addToDirList :: IORef [String] -> String -> IO ()
 412 addToDirList ref path
 413   = do paths <- readIORef ref
 414        writeIORef ref (paths ++ split split_marker path)
 415
 416 -----------------------------------------------------------------------------
 417 -- Packages
 418
 419 GLOBAL_VAR(path_package_config, error "path_package_config", String)
 420
 421 -- package list is maintained in dependency order
 422 packages = global ["std", "rts", "gmp"] :: IORef [String]
 423 -- comma in value, so can't use macro, grrr
 424 {-# NOINLINE packages #-}
 425
 426 addPackage :: String -> IO ()
 427 addPackage package
 428   = do pkg_details <- readIORef package_details
 429        case lookupPkg package pkg_details of
 430           Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
 431           Just details -> do
 432             ps <- readIORef packages
 433             unless (package `elem` ps) $ do
 434                 mapM_ addPackage (package_deps details)
 435                 ps <- readIORef packages
 436                 writeIORef packages (package:ps)
 437
 438 getPackageImportPath   :: IO [String]
 439 getPackageImportPath = do
 440   ps <- readIORef packages
 441   ps' <- getPackageDetails ps
 442   return (nub (concat (map import_dirs ps')))
 443
 444 getPackageIncludePath   :: IO [String]
 445 getPackageIncludePath = do
 446   ps <- readIORef packages
 447   ps' <- getPackageDetails ps
 448   return (nub (filter (not.null) (concatMap include_dirs ps')))
 449
 450         -- includes are in reverse dependency order (i.e. rts first)
 451 getPackageCIncludes   :: IO [String]
 452 getPackageCIncludes = do
 453   ps <- readIORef packages
 454   ps' <- getPackageDetails ps
 455   return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
 456
 457 getPackageLibraryPath  :: IO [String]
 458 getPackageLibraryPath = do
 459   ps <- readIORef packages
 460   ps' <- getPackageDetails ps
 461   return (nub (concat (map library_dirs ps')))
 462
 463 getPackageLibraries    :: IO [String]
 464 getPackageLibraries = do
 465   ps <- readIORef packages
 466   ps' <- getPackageDetails ps
 467   tag <- readIORef build_tag
 468   let suffix = if null tag then "" else '_':tag
 469   return (concat (
 470         map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
 471      ))
 472
 473 getPackageExtraGhcOpts :: IO [String]
 474 getPackageExtraGhcOpts = do
 475   ps <- readIORef packages
 476   ps' <- getPackageDetails ps
 477   return (concatMap extra_ghc_opts ps')
 478
 479 getPackageExtraCcOpts  :: IO [String]
 480 getPackageExtraCcOpts = do
 481   ps <- readIORef packages
 482   ps' <- getPackageDetails ps
 483   return (concatMap extra_cc_opts ps')
 484
 485 getPackageExtraLdOpts  :: IO [String]
 486 getPackageExtraLdOpts = do
 487   ps <- readIORef packages
 488   ps' <- getPackageDetails ps
 489   return (concatMap extra_ld_opts ps')
 490
 491 getPackageDetails :: [String] -> IO [Package]
 492 getPackageDetails ps = do
 493   pkg_details <- readIORef package_details
 494   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 495
 496 GLOBAL_VAR(package_details, (error "package_details"), [Package])
 497
 498 lookupPkg :: String -> [Package] -> Maybe Package
 499 lookupPkg nm ps
 500    = case [p | p <- ps, name p == nm] of
 501         []    -> Nothing
 502         (p:_) -> Just p
 503 -----------------------------------------------------------------------------
 504 -- Ways
 505
 506 -- The central concept of a "way" is that all objects in a given
 507 -- program must be compiled in the same "way".  Certain options change
 508 -- parameters of the virtual machine, eg. profiling adds an extra word
 509 -- to the object header, so profiling objects cannot be linked with
 510 -- non-profiling objects.
 511
 512 -- After parsing the command-line options, we determine which "way" we
 513 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 514
 515 -- We then find the "build-tag" associated with this way, and this
 516 -- becomes the suffix used to find .hi files and libraries used in
 517 -- this compilation.
 518
 519 GLOBAL_VAR(build_tag, "", String)
 520
 521 data WayName
 522   = WayProf
 523   | WayUnreg
 524   | WayDll
 525   | WayTicky
 526   | WayPar
 527   | WayGran
 528   | WaySMP
 529   | WayDebug
 530   | WayUser_a
 531   | WayUser_b
 532   | WayUser_c
 533   | WayUser_d
 534   | WayUser_e
 535   | WayUser_f
 536   | WayUser_g
 537   | WayUser_h
 538   | WayUser_i
 539   | WayUser_j
 540   | WayUser_k
 541   | WayUser_l
 542   | WayUser_m
 543   | WayUser_n
 544   | WayUser_o
 545   | WayUser_A
 546   | WayUser_B
 547   deriving (Eq,Ord)
 548
 549 GLOBAL_VAR(ways, [] ,[WayName])
 550
 551 -- ToDo: allow WayDll with any other allowed combination
 552
 553 allowed_combinations =
 554    [  [WayProf,WayUnreg],
 555       [WayProf,WaySMP]     -- works???
 556    ]
 557
 558 findBuildTag :: IO [String]  -- new options
 559 findBuildTag = do
 560   way_names <- readIORef ways
 561   case sort way_names of
 562      []  -> do  writeIORef build_tag ""
 563                 return []
 564
 565      [w] -> do let details = lkupWay w
 566                writeIORef build_tag (wayTag details)
 567                return (wayOpts details)
 568
 569      ws  -> if  ws `notElem` allowed_combinations
 570                 then throwDyn (OtherError $
 571                                 "combination not supported: "  ++
 572                                 foldr1 (\a b -> a ++ '/':b)
 573                                 (map (wayName . lkupWay) ws))
 574                 else let stuff = map lkupWay ws
 575                          tag   = concat (map wayTag stuff)
 576                          flags = map wayOpts stuff
 577                      in do
 578                      writeIORef build_tag tag
 579                      return (concat flags)
 580
 581 lkupWay w =
 582    case lookup w way_details of
 583         Nothing -> error "findBuildTag"
 584         Just details -> details
 585
 586 data Way = Way {
 587   wayTag   :: String,
 588   wayName  :: String,
 589   wayOpts  :: [String]
 590   }
 591
 592 way_details :: [ (WayName, Way) ]
 593 way_details =
 594   [ (WayProf, Way  "p" "Profiling"
 595         [ "-fscc-profiling"
 596         , "-DPROFILING"
 597         , "-optc-DPROFILING"
 598         , "-fvia-C" ]),
 599
 600     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 601         [ "-fticky-ticky"
 602         , "-DTICKY_TICKY"
 603         , "-optc-DTICKY_TICKY"
 604         , "-fvia-C" ]),
 605
 606     (WayUnreg, Way  "u" "Unregisterised"
 607         [ "-optc-DNO_REGS"
 608         , "-optc-DUSE_MINIINTERPRETER"
 609         , "-fno-asm-mangling"
 610         , "-funregisterised"
 611         , "-fvia-C" ]),
 612
 613     (WayDll, Way  "dll" "DLLized"
 614         [ ]),
 615
 616     (WayPar, Way  "mp" "Parallel"
 617         [ "-fparallel"
 618         , "-D__PARALLEL_HASKELL__"
 619         , "-optc-DPAR"
 620         , "-package concurrent"
 621         , "-fvia-C" ]),
 622
 623     (WayGran, Way  "mg" "Gransim"
 624         [ "-fgransim"
 625         , "-D__GRANSIM__"
 626         , "-optc-DGRAN"
 627         , "-package concurrent"
 628         , "-fvia-C" ]),
 629
 630     (WaySMP, Way  "s" "SMP"
 631         [ "-fsmp"
 632         , "-optc-pthread"
 633         , "-optl-pthread"
 634         , "-optc-DSMP"
 635         , "-fvia-C" ]),
 636
 637     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 638     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 639     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 640     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 641     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 642     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 643     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 644     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 645     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 646     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 647     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 648     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 649     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 650     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 651     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 652     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 653     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 654   ]
 655
 656 -----------------------------------------------------------------------------
 657 -- Programs for particular phases
 658
 659 GLOBAL_VAR(pgm_L,   error "pgm_L", String)
 660 GLOBAL_VAR(pgm_P,   cRAWCPP,       String)
 661 GLOBAL_VAR(pgm_C,   error "pgm_L", String)
 662 GLOBAL_VAR(pgm_c,   cGCC,          String)
 663 GLOBAL_VAR(pgm_m,   error "pgm_m", String)
 664 GLOBAL_VAR(pgm_s,   error "pgm_s", String)
 665 GLOBAL_VAR(pgm_a,   cGCC,          String)
 666 GLOBAL_VAR(pgm_l,   cGCC,          String)
 667
 668 GLOBAL_VAR(opt_dep,    [], [String])
 669 GLOBAL_VAR(anti_opt_C, [], [String])
 670 GLOBAL_VAR(opt_C,      [], [String])
 671 GLOBAL_VAR(opt_l,      [], [String])
 672 GLOBAL_VAR(opt_dll,    [], [String])
 673
 674 -----------------------------------------------------------------------------
 675 -- Via-C compilation stuff
 676
 677 -- flags returned are: ( all C compilations
 678 --                     , registerised HC compilations
 679 --                     )
 680
 681 machdepCCOpts
 682    | prefixMatch "alpha"   cTARGETPLATFORM
 683         = return ( ["-static"], [] )
 684
 685    | prefixMatch "hppa"    cTARGETPLATFORM
 686         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 687         -- (very nice, but too bad the HP /usr/include files don't agree.)
 688         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 689
 690    | prefixMatch "m68k"    cTARGETPLATFORM
 691       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 692       --    popping of args to routines to be explicit; if we let things
 693       --    be deferred 'til after an STGJUMP, imminent death is certain!
 694       --
 695       -- -fomit-frame-pointer : *don't*
 696       --     It's better to have a6 completely tied up being a frame pointer
 697       --     rather than let GCC pick random things to do with it.
 698       --     (If we want to steal a6, then we would try to do things
 699       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 700         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 701
 702    | prefixMatch "i386"    cTARGETPLATFORM
 703       -- -fno-defer-pop : basically the same game as for m68k
 704       --
 705       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 706       --   the fp (%ebp) for our register maps.
 707         = do n_regs <- readState stolen_x86_regs
 708              sta    <- readIORef static
 709              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
 710                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 711                         "-DSTOLEN_X86_REGS="++show n_regs ]
 712                     )
 713
 714    | prefixMatch "mips"    cTARGETPLATFORM
 715         = return ( ["static"], [] )
 716
 717    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 718         = return ( ["static"], ["-finhibit-size-directive"] )
 719
 720    | otherwise
 721         = return ( [], [] )
 722
 723
 724 -----------------------------------------------------------------------------
 725 -- Running an external program
 726
 727 run_something phase_name cmd
 728  = do
 729    verb <- readIORef verbose
 730    when verb $ do
 731         putStr phase_name
 732         putStrLn ":"
 733         putStrLn cmd
 734         hFlush stdout
 735
 736    -- test for -n flag
 737    n <- readIORef dry_run
 738    unless n $ do
 739
 740    -- and run it!
 741 #ifndef mingw32_TARGET_OS
 742    exit_code <- system cmd `catchAllIO`
 743                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 744 #else
 745    tmp <- newTempName "sh"
 746    h <- openFile tmp WriteMode
 747    hPutStrLn h cmd
 748    hClose h
 749    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 750                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
 751    removeFile tmp
 752 #endif
 753
 754    if exit_code /= ExitSuccess
 755         then throwDyn (PhaseFailed phase_name exit_code)
 756         else do when verb (putStr "\n")
 757                 return ()
 758
 759 -----------------------------------------------------------------------------
 760 -- File suffixes & things
 761
 762 -- the output suffix for a given phase is uniquely determined by
 763 -- the input requirements of the next phase.
 764
 765 unlitInputExt       = "lhs"
 766 cppInputExt         = "lpp"
 767 hscInputExt         = "cpp"
 768 hccInputExt         = "hc"
 769 ccInputExt          = "c"
 770 mangleInputExt      = "raw_s"
 771 asInputExt          = "s"
 772 lnInputExt          = "o"