ghc/driver/Main.hs

   1 {-# OPTIONS -W -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.69 2000/11/07 10:42:55 simonmar Exp $
   4 --
   5 -- GHC Driver program
   6 --
   7 -- (c) Simon Marlow 2000
   8 --
   9 -----------------------------------------------------------------------------
  10
  11 -- with path so that ghc -M can find config.h
  12 #include "../includes/config.h"
  13
  14 module Main (main) where
  15
  16 import Utils
  17
  18 import GetImports
  19 import Package
  20 import Config
  21
  22 import RegexString
  23 import Concurrent
  24 #ifndef mingw32_TARGET_OS
  25 import Posix
  26 #endif
  27 import Directory
  28 import IOExts
  29 import Exception
  30 import Dynamic
  31
  32 import IO
  33 import Monad
  34 import List
  35 import System
  36 import Maybe
  37 import Char
  38
  39 #ifdef mingw32_TARGET_OS
  40 foreign import "_getpid" getProcessID :: IO Int
  41 #endif
  42
  43 #define GLOBAL_VAR(name,value,ty)  \
  44 name = global (value) :: IORef (ty); \
  45 {-# NOINLINE name #-}
  46
  47 -----------------------------------------------------------------------------
  48 -- ToDo:
  49
  50 -- certain options in OPTIONS pragmas are persistent through subsequent compilations.
  51 -- new mkdependHS doesn't support all the options that the old one did (-X et al.)
  52 -- time commands when run with -v
  53 -- split marker
  54 -- mkDLL
  55 -- java generation
  56 -- user ways
  57 -- Win32 support: proper signal handling
  58 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
  59 -- reading the package configuration file is too slow
  60
  61 -----------------------------------------------------------------------------
  62 -- Differences vs. old driver:
  63
  64 -- No more "Enter your Haskell program, end with ^D (on a line of its own):"
  65 -- consistency checking removed (may do this properly later)
  66 -- removed -noC
  67 -- no hi diffs (could be added later)
  68 -- no -Ofile
  69
  70 -----------------------------------------------------------------------------
  71 -- non-configured things
  72
  73 cHaskell1Version = "5" -- i.e., Haskell 98
  74
  75 -----------------------------------------------------------------------------
  76 -- Usage Message
  77
  78 short_usage = "Usage: For basic information, try the `--help' option."
  79
  80 long_usage = do
  81   let usage_file = "ghc-usage.txt"
  82       usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
  83   usage <- readFile usage_path
  84   dump usage
  85   exitWith ExitSuccess
  86   where
  87      dump "" = return ()
  88      dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
  89      dump (c:s) = hPutChar stderr c >> dump s
  90
  91 version_str = cProjectVersion
  92
  93 -----------------------------------------------------------------------------
  94 -- Driver state
  95
  96 -- certain flags can be specified on a per-file basis, in an OPTIONS
  97 -- pragma at the beginning of the source file.  This means that when
  98 -- compiling mulitple files, we have to restore the global option
  99 -- settings before compiling a new file.
 100 --
 101 -- The DriverState record contains the per-file-mutable state.
 102
 103 data DriverState = DriverState {
 104
 105         -- are we runing cpp on this file?
 106         cpp_flag                :: Bool,
 107
 108         -- heap/stack sizes
 109         specific_heap_size      :: Integer,
 110         specific_stack_size     :: Integer,
 111
 112         -- misc
 113         stolen_x86_regs         :: Int,
 114         excess_precision        :: Bool,
 115         warning_opt             :: WarningState,
 116         cmdline_hc_includes     :: [String],
 117
 118         -- options for a particular phase
 119         anti_opt_C              :: [String],
 120         opt_dep                 :: [String],
 121         opt_L                   :: [String],
 122         opt_P                   :: [String],
 123         opt_C                   :: [String],
 124         opt_Crts                :: [String],
 125         opt_c                   :: [String],
 126         opt_a                   :: [String],
 127         opt_m                   :: [String],
 128         opt_l                   :: [String],
 129         opt_dll                 :: [String]
 130    }
 131
 132 initDriverState = DriverState {
 133         cpp_flag                = False,
 134         specific_heap_size      = 6 * 1000 * 1000,
 135         specific_stack_size     = 1000 * 1000,
 136         stolen_x86_regs         = 4,
 137         excess_precision        = False,
 138         warning_opt             = W_default,
 139         cmdline_hc_includes     = [],
 140         anti_opt_C              = [],
 141         opt_dep                 = [],
 142         opt_L                   = [],
 143         opt_P                   = [],
 144         opt_C                   = [],
 145         opt_Crts                = [],
 146         opt_c                   = [],
 147         opt_a                   = [],
 148         opt_m                   = [],
 149         opt_l                   = [],
 150         opt_dll                 = []
 151    }
 152
 153 GLOBAL_VAR(driver_state, initDriverState, DriverState)
 154
 155 readState :: (DriverState -> a) -> IO a
 156 readState f = readIORef driver_state >>= return . f
 157
 158 updateState :: (DriverState -> DriverState) -> IO ()
 159 updateState f = readIORef driver_state >>= writeIORef driver_state . f
 160
 161 addAntiOpt_C a = updateState (\s -> s{anti_opt_C =  a : anti_opt_C s})
 162 addOpt_dep   a = updateState (\s -> s{opt_dep    =  a : opt_dep    s})
 163 addOpt_L     a = updateState (\s -> s{opt_L      =  a : opt_L      s})
 164 addOpt_P     a = updateState (\s -> s{opt_P      =  a : opt_P      s})
 165 addOpt_C     a = updateState (\s -> s{opt_C      =  a : opt_C      s})
 166 addOpt_Crts  a = updateState (\s -> s{opt_Crts   =  a : opt_Crts   s})
 167 addOpt_c     a = updateState (\s -> s{opt_c      =  a : opt_c      s})
 168 addOpt_a     a = updateState (\s -> s{opt_a      =  a : opt_a      s})
 169 addOpt_m     a = updateState (\s -> s{opt_m      =  a : opt_m      s})
 170 addOpt_l     a = updateState (\s -> s{opt_l      =  a : opt_l      s})
 171 addOpt_dll   a = updateState (\s -> s{opt_dll    =  a : opt_dll    s})
 172
 173 addCmdlineHCInclude a =
 174    updateState (\s -> s{cmdline_hc_includes =  a : cmdline_hc_includes s})
 175
 176         -- we add to the options from the front, so we need to reverse the list
 177 getOpts :: (DriverState -> [a]) -> IO [a]
 178 getOpts opts = readState opts >>= return . reverse
 179
 180 newHeapSize :: Integer -> IO ()
 181 newHeapSize new = updateState
 182    (\s -> let current = specific_heap_size s in
 183           s{ specific_heap_size = if new > current then new else current })
 184
 185 newStackSize :: Integer -> IO ()
 186 newStackSize new = updateState
 187    (\s -> let current = specific_stack_size s in
 188           s{ specific_stack_size = if new > current then new else current })
 189
 190 -----------------------------------------------------------------------------
 191 -- Phases
 192
 193 {-
 194 Phase of the           | Suffix saying | Flag saying   | (suffix of)
 195 compilation system     | ``start here''| ``stop after''| output file
 196
 197 literate pre-processor | .lhs          | -             | -
 198 C pre-processor (opt.) | -             | -E            | -
 199 Haskell compiler       | .hs           | -C, -S        | .hc, .s
 200 C compiler (opt.)      | .hc or .c     | -S            | .s
 201 assembler              | .s  or .S     | -c            | .o
 202 linker                 | other         | -             | a.out
 203 -}
 204
 205 data Phase
 206         = MkDependHS    -- haskell dependency generation
 207         | Unlit
 208         | Cpp
 209         | Hsc
 210         | Cc
 211         | HCc           -- Haskellised C (as opposed to vanilla C) compilation
 212         | Mangle        -- assembly mangling, now done by a separate script.
 213         | SplitMangle   -- after mangler if splitting
 214         | SplitAs
 215         | As
 216         | Ln
 217   deriving (Eq)
 218
 219 -----------------------------------------------------------------------------
 220 -- Errors
 221
 222 data BarfKind
 223   = PhaseFailed String ExitCode
 224   | Interrupted
 225   | UsageError String                   -- prints the short usage msg after the error
 226   | OtherError String                   -- just prints the error message
 227   deriving Eq
 228
 229 GLOBAL_VAR(prog_name, "ghc", String)
 230
 231 get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
 232
 233 instance Show BarfKind where
 234   showsPrec _ e
 235         = showString get_prog_name . showString ": " . showBarf e
 236
 237 showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
 238 showBarf (OtherError str) = showString str
 239 showBarf (PhaseFailed phase code) =
 240         showString phase . showString " failed, code = " . shows code
 241 showBarf (Interrupted) = showString "interrupted"
 242
 243 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
 244
 245 barfKindTc = mkTyCon "BarfKind"
 246 instance Typeable BarfKind where
 247   typeOf _ = mkAppTy barfKindTc []
 248
 249 -----------------------------------------------------------------------------
 250 -- Temporary files
 251
 252 GLOBAL_VAR(files_to_clean, [], [String])
 253 GLOBAL_VAR(keep_tmp_files, False, Bool)
 254
 255 cleanTempFiles :: IO ()
 256 cleanTempFiles = do
 257   forget_it <- readIORef keep_tmp_files
 258   unless forget_it $ do
 259
 260   fs <- readIORef files_to_clean
 261   verb <- readIORef verbose
 262
 263   let blowAway f =
 264            (do  when verb (hPutStrLn stderr ("removing: " ++ f))
 265                 if '*' `elem` f then system ("rm -f " ++ f) >> return ()
 266                                 else removeFile f)
 267             `catchAllIO`
 268            (\_ -> when verb (hPutStrLn stderr
 269                                 ("warning: can't remove tmp file" ++ f)))
 270   mapM_ blowAway fs
 271
 272 -----------------------------------------------------------------------------
 273 -- Global compilation flags
 274
 275         -- Cpp-related flags
 276 hs_source_cpp_opts = global
 277         [ "-D__HASKELL1__="++cHaskell1Version
 278         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
 279         , "-D__HASKELL98__"
 280         , "-D__CONCURRENT_HASKELL__"
 281         ]
 282
 283         -- Verbose
 284 GLOBAL_VAR(verbose, False, Bool)
 285 is_verbose = do v <- readIORef verbose; if v then return "-v" else return ""
 286
 287         -- Keep output from intermediate phases
 288 GLOBAL_VAR(keep_hi_diffs,       False,          Bool)
 289 GLOBAL_VAR(keep_hc_files,       False,          Bool)
 290 GLOBAL_VAR(keep_s_files,        False,          Bool)
 291 GLOBAL_VAR(keep_raw_s_files,    False,          Bool)
 292
 293         -- Misc
 294 GLOBAL_VAR(scale_sizes_by,      1.0,            Double)
 295 GLOBAL_VAR(dry_run,             False,          Bool)
 296 GLOBAL_VAR(recomp,              True,           Bool)
 297 GLOBAL_VAR(tmpdir,              cDEFAULT_TMPDIR, String)
 298 #if !defined(HAVE_WIN32_DLL_SUPPORT) || defined(DONT_WANT_WIN32_DLL_SUPPORT)
 299 GLOBAL_VAR(static,              True,           Bool)
 300 #else
 301 GLOBAL_VAR(static,              False,          Bool)
 302 #endif
 303 GLOBAL_VAR(collect_ghc_timing,  False,          Bool)
 304 GLOBAL_VAR(do_asm_mangling,     True,           Bool)
 305
 306 -----------------------------------------------------------------------------
 307 -- Splitting object files (for libraries)
 308
 309 GLOBAL_VAR(split_object_files,  False,          Bool)
 310 GLOBAL_VAR(split_prefix,        "",             String)
 311 GLOBAL_VAR(n_split_files,       0,              Int)
 312
 313 can_split :: Bool
 314 can_split =  prefixMatch "i386" cTARGETPLATFORM
 315           || prefixMatch "alpha" cTARGETPLATFORM
 316           || prefixMatch "hppa" cTARGETPLATFORM
 317           || prefixMatch "m68k" cTARGETPLATFORM
 318           || prefixMatch "mips" cTARGETPLATFORM
 319           || prefixMatch "powerpc" cTARGETPLATFORM
 320           || prefixMatch "rs6000" cTARGETPLATFORM
 321           || prefixMatch "sparc" cTARGETPLATFORM
 322
 323 -----------------------------------------------------------------------------
 324 -- Compiler output options
 325
 326 data HscLang
 327   = HscC
 328   | HscAsm
 329   | HscJava
 330   deriving Eq
 331
 332 GLOBAL_VAR(hsc_lang, if cGhcWithNativeCodeGen == "YES" &&
 333                          (prefixMatch "i386" cTARGETPLATFORM ||
 334                           prefixMatch "sparc" cTARGETPLATFORM)
 335                         then  HscAsm
 336                         else  HscC,
 337            HscLang)
 338
 339 GLOBAL_VAR(output_dir,  Nothing, Maybe String)
 340 GLOBAL_VAR(output_suf,  Nothing, Maybe String)
 341 GLOBAL_VAR(output_file, Nothing, Maybe String)
 342 GLOBAL_VAR(output_hi,   Nothing, Maybe String)
 343
 344 GLOBAL_VAR(ld_inputs,   [],      [String])
 345
 346 odir_ify :: String -> IO String
 347 odir_ify f = do
 348   odir_opt <- readIORef output_dir
 349   case odir_opt of
 350         Nothing -> return f
 351         Just d  -> return (newdir d f)
 352
 353 osuf_ify :: String -> IO String
 354 osuf_ify f = do
 355   osuf_opt <- readIORef output_suf
 356   case osuf_opt of
 357         Nothing -> return f
 358         Just s  -> return (newsuf s f)
 359
 360 -----------------------------------------------------------------------------
 361 -- Hi Files
 362
 363 GLOBAL_VAR(produceHi,           True,   Bool)
 364 GLOBAL_VAR(hi_on_stdout,        False,  Bool)
 365 GLOBAL_VAR(hi_with,             "",     String)
 366 GLOBAL_VAR(hi_suf,              "hi",   String)
 367
 368 data HiDiffFlag = NormalHiDiffs | UsageHiDiffs | NoHiDiffs
 369 GLOBAL_VAR(hi_diffs, NoHiDiffs, HiDiffFlag)
 370
 371 -----------------------------------------------------------------------------
 372 -- Warnings & sanity checking
 373
 374 -- Warning packages that are controlled by -W and -Wall.  The 'standard'
 375 -- warnings that you get all the time are
 376 --
 377 --         -fwarn-overlapping-patterns
 378 --         -fwarn-missing-methods
 379 --         -fwarn-missing-fields
 380 --         -fwarn-deprecations
 381 --         -fwarn-duplicate-exports
 382 --
 383 -- these are turned off by -Wnot.
 384
 385 standardWarnings  = [ "-fwarn-overlapping-patterns"
 386                     , "-fwarn-missing-methods"
 387                     , "-fwarn-missing-fields"
 388                     , "-fwarn-deprecations"
 389                     , "-fwarn-duplicate-exports"
 390                     ]
 391 minusWOpts        = standardWarnings ++
 392                     [ "-fwarn-unused-binds"
 393                     , "-fwarn-unused-matches"
 394                     , "-fwarn-incomplete-patterns"
 395                     , "-fwarn-unused-imports"
 396                     ]
 397 minusWallOpts     = minusWOpts ++
 398                     [ "-fwarn-type-defaults"
 399                     , "-fwarn-name-shadowing"
 400                     , "-fwarn-missing-signatures"
 401                     , "-fwarn-hi-shadowing"
 402                     ]
 403
 404 data WarningState = W_default | W_ | W_all | W_not
 405
 406 -----------------------------------------------------------------------------
 407 -- Compiler optimisation options
 408
 409 GLOBAL_VAR(opt_level, 0, Int)
 410
 411 setOptLevel :: String -> IO ()
 412 setOptLevel ""              = do { writeIORef opt_level 1; go_via_C }
 413 setOptLevel "not"           = writeIORef opt_level 0
 414 setOptLevel [c] | isDigit c = do
 415    let level = ord c - ord '0'
 416    writeIORef opt_level level
 417    when (level >= 1) go_via_C
 418 setOptLevel s = unknownFlagErr ("-O"++s)
 419
 420 go_via_C = do
 421    l <- readIORef hsc_lang
 422    case l of { HscAsm -> writeIORef hsc_lang HscC;
 423                _other -> return () }
 424
 425 GLOBAL_VAR(opt_minus_o2_for_C, False, Bool)
 426
 427 GLOBAL_VAR(opt_MaxSimplifierIterations, 4, Int)
 428 GLOBAL_VAR(opt_StgStats,    False, Bool)
 429 GLOBAL_VAR(opt_UsageSPInf,  False, Bool)  -- Off by default
 430
 431 hsc_minusO2_flags = hsc_minusO_flags    -- for now
 432
 433 hsc_minusNoO_flags = do
 434   iter        <- readIORef opt_MaxSimplifierIterations
 435   return [
 436         "-fignore-interface-pragmas",
 437         "-fomit-interface-pragmas",
 438         "-fsimplify",
 439             "[",
 440                 "-fmax-simplifier-iterations" ++ show iter,
 441             "]"
 442         ]
 443
 444 hsc_minusO_flags = do
 445   iter       <- readIORef opt_MaxSimplifierIterations
 446   usageSP    <- readIORef opt_UsageSPInf
 447   stgstats   <- readIORef opt_StgStats
 448
 449   return [
 450         "-ffoldr-build-on",
 451
 452         "-fdo-eta-reduction",
 453         "-fdo-lambda-eta-expansion",
 454         "-fcase-of-case",
 455         "-fcase-merge",
 456         "-flet-to-case",
 457
 458         -- initial simplify: mk specialiser happy: minimum effort please
 459
 460         "-fsimplify",
 461           "[",
 462                 "-finline-phase0",
 463                         -- Don't inline anything till full laziness has bitten
 464                         -- In particular, inlining wrappers inhibits floating
 465                         -- e.g. ...(case f x of ...)...
 466                         --  ==> ...(case (case x of I# x# -> fw x#) of ...)...
 467                         --  ==> ...(case x of I# x# -> case fw x# of ...)...
 468                         -- and now the redex (f x) isn't floatable any more
 469
 470                 "-fno-rules",
 471                         -- Similarly, don't apply any rules until after full
 472                         -- laziness.  Notably, list fusion can prevent floating.
 473
 474                 "-fno-case-of-case",
 475                         -- Don't do case-of-case transformations.
 476                         -- This makes full laziness work better
 477
 478                 "-fmax-simplifier-iterations2",
 479           "]",
 480
 481         -- Specialisation is best done before full laziness
 482         -- so that overloaded functions have all their dictionary lambdas manifest
 483         "-fspecialise",
 484
 485         "-ffloat-outwards",
 486         "-ffloat-inwards",
 487
 488         "-fsimplify",
 489           "[",
 490                 "-finline-phase1",
 491                 -- Want to run with inline phase 1 after the specialiser to give
 492                 -- maximum chance for fusion to work before we inline build/augment
 493                 -- in phase 2.  This made a difference in 'ansi' where an
 494                 -- overloaded function wasn't inlined till too late.
 495                 "-fmax-simplifier-iterations" ++ show iter,
 496           "]",
 497
 498         -- infer usage information here in case we need it later.
 499         -- (add more of these where you need them --KSW 1999-04)
 500         if usageSP then "-fusagesp" else "",
 501
 502         "-fsimplify",
 503           "[",
 504                 -- Need inline-phase2 here so that build/augment get
 505                 -- inlined.  I found that spectral/hartel/genfft lost some useful
 506                 -- strictness in the function sumcode' if augment is not inlined
 507                 -- before strictness analysis runs
 508
 509                 "-finline-phase2",
 510                 "-fmax-simplifier-iterations2",
 511           "]",
 512
 513         "-fsimplify",
 514           "[",
 515                 "-fmax-simplifier-iterations2",
 516                 -- No -finline-phase: allow all Ids to be inlined now
 517                 -- This gets foldr inlined before strictness analysis
 518           "]",
 519
 520         "-fstrictness",
 521         "-fcpr-analyse",
 522         "-fworker-wrapper",
 523         "-fglom-binds",
 524
 525         "-fsimplify",
 526           "[",
 527                 "-fmax-simplifier-iterations" ++ show iter,
 528                 -- No -finline-phase: allow all Ids to be inlined now
 529           "]",
 530
 531         "-ffloat-outwards",
 532                 -- nofib/spectral/hartel/wang doubles in speed if you
 533                 -- do full laziness late in the day.  It only happens
 534                 -- after fusion and other stuff, so the early pass doesn't
 535                 -- catch it.  For the record, the redex is
 536                 --        f_el22 (f_el21 r_midblock)
 537
 538 -- Leave out lambda lifting for now
 539 --        "-fsimplify", -- Tidy up results of full laziness
 540 --          "[",
 541 --                "-fmax-simplifier-iterations2",
 542 --          "]",
 543 --        "-ffloat-outwards-full",
 544
 545         -- We want CSE to follow the final full-laziness pass, because it may
 546         -- succeed in commoning up things floated out by full laziness.
 547         --
 548         -- CSE must immediately follow a simplification pass, because it relies
 549         -- on the no-shadowing invariant.  See comments at the top of CSE.lhs
 550         -- So it must NOT follow float-inwards, which can give rise to shadowing,
 551         -- even if its input doesn't have shadows.  Hence putting it between
 552         -- the two passes.
 553         "-fcse",
 554
 555
 556         "-ffloat-inwards",
 557
 558 -- Case-liberation for -O2.  This should be after
 559 -- strictness analysis and the simplification which follows it.
 560
 561 --        ( ($OptLevel != 2)
 562 --        ? ""
 563 --        : "-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 ]" ),
 564 --
 565 --        "-fliberate-case",
 566
 567         -- Final clean-up simplification:
 568         "-fsimplify",
 569           "[",
 570                 "-fmax-simplifier-iterations" ++ show iter,
 571                 -- No -finline-phase: allow all Ids to be inlined now
 572           "]"
 573
 574         ]
 575
 576 -----------------------------------------------------------------------------
 577 -- Paths & Libraries
 578
 579 split_marker = ':'   -- not configurable (ToDo)
 580
 581 import_paths, include_paths, library_paths :: IORef [String]
 582 GLOBAL_VAR(import_paths,  ["."], [String])
 583 GLOBAL_VAR(include_paths, ["."], [String])
 584 GLOBAL_VAR(library_paths, [],    [String])
 585
 586 GLOBAL_VAR(cmdline_libraries,   [], [String])
 587
 588 addToDirList :: IORef [String] -> String -> IO ()
 589 addToDirList ref path
 590   = do paths <- readIORef ref
 591        writeIORef ref (paths ++ split split_marker path)
 592
 593 -----------------------------------------------------------------------------
 594 -- Packages
 595
 596 GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
 597
 598 listPackages :: IO ()
 599 listPackages = do
 600   details <- readIORef package_details
 601   hPutStr stdout (listPkgs details)
 602   hPutChar stdout '\n'
 603   exitWith ExitSuccess
 604
 605 newPackage :: IO ()
 606 newPackage = do
 607   checkConfigAccess
 608   details <- readIORef package_details
 609   hPutStr stdout "Reading package info from stdin... "
 610   stuff <- getContents
 611   let new_pkg = read stuff :: Package
 612   catchAll new_pkg
 613         (\_ -> throwDyn (OtherError "parse error in package info"))
 614   hPutStrLn stdout "done."
 615   if (name new_pkg `elem` map name details)
 616         then throwDyn (OtherError ("package `" ++ name new_pkg ++
 617                                         "' already installed"))
 618         else do
 619   conf_file <- readIORef package_config
 620   savePackageConfig conf_file
 621   maybeRestoreOldConfig conf_file $ do
 622   writeNewConfig conf_file ( ++ [new_pkg])
 623   exitWith ExitSuccess
 624
 625 deletePackage :: String -> IO ()
 626 deletePackage pkg = do
 627   checkConfigAccess
 628   details <- readIORef package_details
 629   if (pkg `notElem` map name details)
 630         then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
 631         else do
 632   conf_file <- readIORef package_config
 633   savePackageConfig conf_file
 634   maybeRestoreOldConfig conf_file $ do
 635   writeNewConfig conf_file (filter ((/= pkg) . name))
 636   exitWith ExitSuccess
 637
 638 checkConfigAccess :: IO ()
 639 checkConfigAccess = do
 640   conf_file <- readIORef package_config
 641   access <- getPermissions conf_file
 642   unless (writable access)
 643         (throwDyn (OtherError "you don't have permission to modify the package configuration file"))
 644
 645 maybeRestoreOldConfig :: String -> IO () -> IO ()
 646 maybeRestoreOldConfig conf_file io
 647   = catchAllIO io (\e -> do
 648         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 649                        \configuration was being written.  Attempting to \n\
 650                        \restore the old configuration... "
 651         system ("cp " ++ conf_file ++ ".old " ++ conf_file)
 652         hPutStrLn stdout "done."
 653         throw e
 654     )
 655
 656 writeNewConfig :: String -> ([Package] -> [Package]) -> IO ()
 657 writeNewConfig conf_file fn = do
 658   hPutStr stdout "Writing new package config file... "
 659   old_details <- readIORef package_details
 660   h <- openFile conf_file WriteMode
 661   hPutStr h (dumpPackages (fn old_details))
 662   hClose h
 663   hPutStrLn stdout "done."
 664
 665 savePackageConfig :: String -> IO ()
 666 savePackageConfig conf_file = do
 667   hPutStr stdout "Saving old package config file... "
 668     -- mv rather than cp because we've already done an hGetContents
 669     -- on this file so we won't be able to open it for writing
 670     -- unless we move the old one out of the way...
 671   system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
 672   hPutStrLn stdout "done."
 673
 674 -- package list is maintained in dependency order
 675 packages = global ["std", "rts", "gmp"] :: IORef [String]
 676 -- comma in value, so can't use macro, grrr
 677 {-# NOINLINE packages #-}
 678
 679 addPackage :: String -> IO ()
 680 addPackage package
 681   = do pkg_details <- readIORef package_details
 682        case lookupPkg package pkg_details of
 683           Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
 684           Just details -> do
 685             ps <- readIORef packages
 686             unless (package `elem` ps) $ do
 687                 mapM_ addPackage (package_deps details)
 688                 ps <- readIORef packages
 689                 writeIORef packages (package:ps)
 690
 691 getPackageImportPath   :: IO [String]
 692 getPackageImportPath = do
 693   ps <- readIORef packages
 694   ps' <- getPackageDetails ps
 695   return (nub (concat (map import_dirs ps')))
 696
 697 getPackageIncludePath   :: IO [String]
 698 getPackageIncludePath = do
 699   ps <- readIORef packages
 700   ps' <- getPackageDetails ps
 701   return (nub (filter (not.null) (concatMap include_dirs ps')))
 702
 703         -- includes are in reverse dependency order (i.e. rts first)
 704 getPackageCIncludes   :: IO [String]
 705 getPackageCIncludes = do
 706   ps <- readIORef packages
 707   ps' <- getPackageDetails ps
 708   return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
 709
 710 getPackageLibraryPath  :: IO [String]
 711 getPackageLibraryPath = do
 712   ps <- readIORef packages
 713   ps' <- getPackageDetails ps
 714   return (nub (concat (map library_dirs ps')))
 715
 716 getPackageLibraries    :: IO [String]
 717 getPackageLibraries = do
 718   ps <- readIORef packages
 719   ps' <- getPackageDetails ps
 720   tag <- readIORef build_tag
 721   let suffix = if null tag then "" else '_':tag
 722   return (concat (
 723         map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
 724      ))
 725
 726 getPackageExtraGhcOpts :: IO [String]
 727 getPackageExtraGhcOpts = do
 728   ps <- readIORef packages
 729   ps' <- getPackageDetails ps
 730   return (concatMap extra_ghc_opts ps')
 731
 732 getPackageExtraCcOpts  :: IO [String]
 733 getPackageExtraCcOpts = do
 734   ps <- readIORef packages
 735   ps' <- getPackageDetails ps
 736   return (concatMap extra_cc_opts ps')
 737
 738 getPackageExtraLdOpts  :: IO [String]
 739 getPackageExtraLdOpts = do
 740   ps <- readIORef packages
 741   ps' <- getPackageDetails ps
 742   return (concatMap extra_ld_opts ps')
 743
 744 getPackageDetails :: [String] -> IO [Package]
 745 getPackageDetails ps = do
 746   pkg_details <- readIORef package_details
 747   return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
 748
 749 GLOBAL_VAR(package_details, (error "package_details"), [Package])
 750
 751 lookupPkg :: String -> [Package] -> Maybe Package
 752 lookupPkg nm ps
 753    = case [p | p <- ps, name p == nm] of
 754         []    -> Nothing
 755         (p:_) -> Just p
 756
 757 -----------------------------------------------------------------------------
 758 -- Ways
 759
 760 -- The central concept of a "way" is that all objects in a given
 761 -- program must be compiled in the same "way".  Certain options change
 762 -- parameters of the virtual machine, eg. profiling adds an extra word
 763 -- to the object header, so profiling objects cannot be linked with
 764 -- non-profiling objects.
 765
 766 -- After parsing the command-line options, we determine which "way" we
 767 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 768
 769 -- We then find the "build-tag" associated with this way, and this
 770 -- becomes the suffix used to find .hi files and libraries used in
 771 -- this compilation.
 772
 773 GLOBAL_VAR(build_tag, "", String)
 774
 775 data WayName
 776   = WayProf
 777   | WayUnreg
 778   | WayTicky
 779   | WayPar
 780   | WayGran
 781   | WaySMP
 782   | WayDebug
 783   | WayUser_a
 784   | WayUser_b
 785   | WayUser_c
 786   | WayUser_d
 787   | WayUser_e
 788   | WayUser_f
 789   | WayUser_g
 790   | WayUser_h
 791   | WayUser_i
 792   | WayUser_j
 793   | WayUser_k
 794   | WayUser_l
 795   | WayUser_m
 796   | WayUser_n
 797   | WayUser_o
 798   | WayUser_A
 799   | WayUser_B
 800   deriving (Eq,Ord)
 801
 802 GLOBAL_VAR(ways, [] ,[WayName])
 803
 804 allowed_combination ways = ways `elem` combs
 805   where  -- the sub-lists must be ordered according to WayName, because findBuildTag sorts them
 806     combs                = [ [WayProf,WayUnreg], [WayProf,WaySMP] ]
 807
 808 findBuildTag :: IO [String]  -- new options
 809 findBuildTag = do
 810   way_names <- readIORef ways
 811   case sort way_names of
 812      []  -> do  writeIORef build_tag ""
 813                 return []
 814
 815      [w] -> do let details = lkupWay w
 816                writeIORef build_tag (wayTag details)
 817                return (wayOpts details)
 818
 819      ws  -> if  allowed_combination ws
 820                 then throwDyn (OtherError $
 821                                 "combination not supported: "  ++
 822                                 foldr1 (\a b -> a ++ '/':b)
 823                                 (map (wayName . lkupWay) ws))
 824                 else let stuff = map lkupWay ws
 825                          tag   = concat (map wayTag stuff)
 826                          flags = map wayOpts stuff
 827                      in do
 828                      writeIORef build_tag tag
 829                      return (concat flags)
 830
 831 lkupWay w =
 832    case lookup w way_details of
 833         Nothing -> error "findBuildTag"
 834         Just details -> details
 835
 836 data Way = Way {
 837   wayTag   :: String,
 838   wayName  :: String,
 839   wayOpts  :: [String]
 840   }
 841
 842 way_details :: [ (WayName, Way) ]
 843 way_details =
 844   [ (WayProf, Way  "p" "Profiling"
 845         [ "-fscc-profiling"
 846         , "-DPROFILING"
 847         , "-optc-DPROFILING"
 848         , "-fvia-C" ]),
 849
 850     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 851         [ "-fticky-ticky"
 852         , "-DTICKY_TICKY"
 853         , "-optc-DTICKY_TICKY"
 854         , "-fvia-C" ]),
 855
 856     (WayUnreg, Way  "u" "Unregisterised"
 857         [ "-optc-DNO_REGS"
 858         , "-optc-DUSE_MINIINTERPRETER"
 859         , "-fno-asm-mangling"
 860         , "-funregisterised"
 861         , "-fvia-C" ]),
 862
 863     (WayPar, Way  "mp" "Parallel"
 864         [ "-fparallel"
 865         , "-D__PARALLEL_HASKELL__"
 866         , "-optc-DPAR"
 867         , "-package concurrent"
 868         , "-fvia-C" ]),
 869
 870     (WayGran, Way  "mg" "Gransim"
 871         [ "-fgransim"
 872         , "-D__GRANSIM__"
 873         , "-optc-DGRAN"
 874         , "-package concurrent"
 875         , "-fvia-C" ]),
 876
 877     (WaySMP, Way  "s" "SMP"
 878         [ "-fsmp"
 879         , "-optc-pthread"
 880         , "-optl-pthread"
 881         , "-optc-DSMP"
 882         , "-fvia-C" ]),
 883
 884     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 885     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 886     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 887     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 888     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 889     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 890     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 891     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 892     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 893     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 894     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 895     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 896     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 897     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 898     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 899     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 900     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 901   ]
 902
 903 -----------------------------------------------------------------------------
 904 -- Programs for particular phases
 905
 906 GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
 907 GLOBAL_VAR(pgm_P,   cRAWCPP,                               String)
 908 GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
 909 GLOBAL_VAR(pgm_c,   cGCC,                                  String)
 910 GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
 911 GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
 912 GLOBAL_VAR(pgm_a,   cGCC,                                  String)
 913 GLOBAL_VAR(pgm_l,   cGCC,                                  String)
 914
 915 -----------------------------------------------------------------------------
 916 -- Via-C compilation stuff
 917
 918 -- flags returned are: ( all C compilations
 919 --                     , registerised HC compilations
 920 --                     )
 921
 922 machdepCCOpts
 923    | prefixMatch "alpha"   cTARGETPLATFORM
 924         = return ( ["-static"], [] )
 925
 926    | prefixMatch "hppa"    cTARGETPLATFORM
 927         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 928         -- (very nice, but too bad the HP /usr/include files don't agree.)
 929         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 930
 931    | prefixMatch "m68k"    cTARGETPLATFORM
 932       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 933       --    popping of args to routines to be explicit; if we let things
 934       --    be deferred 'til after an STGJUMP, imminent death is certain!
 935       --
 936       -- -fomit-frame-pointer : *don't*
 937       --     It's better to have a6 completely tied up being a frame pointer
 938       --     rather than let GCC pick random things to do with it.
 939       --     (If we want to steal a6, then we would try to do things
 940       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 941         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 942
 943    | prefixMatch "i386"    cTARGETPLATFORM
 944       -- -fno-defer-pop : basically the same game as for m68k
 945       --
 946       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 947       --   the fp (%ebp) for our register maps.
 948         = do n_regs <- readState stolen_x86_regs
 949              sta    <- readIORef static
 950              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "",
 951                         if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" ],
 952                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 953                         "-DSTOLEN_X86_REGS="++show n_regs]
 954                     )
 955
 956    | prefixMatch "mips"    cTARGETPLATFORM
 957         = return ( ["static"], [] )
 958
 959    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 960         = return ( ["static"], ["-finhibit-size-directive"] )
 961
 962    | otherwise
 963         = return ( [], [] )
 964
 965 -----------------------------------------------------------------------------
 966 -- Build the Hsc command line
 967
 968 build_hsc_opts :: IO [String]
 969 build_hsc_opts = do
 970   opt_C_ <- getOpts opt_C               -- misc hsc opts
 971
 972         -- warnings
 973   warn_level <- readState warning_opt
 974   let warn_opts =  case warn_level of
 975                         W_default -> standardWarnings
 976                         W_        -> minusWOpts
 977                         W_all     -> minusWallOpts
 978                         W_not     -> []
 979
 980         -- optimisation
 981   minus_o <- readIORef opt_level
 982   optimisation_opts <-
 983         case minus_o of
 984             0 -> hsc_minusNoO_flags
 985             1 -> hsc_minusO_flags
 986             2 -> hsc_minusO2_flags
 987             _ -> error "unknown opt level"
 988             -- ToDo: -Ofile
 989
 990         -- STG passes
 991   ways_ <- readIORef ways
 992   let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
 993                   | otherwise            = ""
 994
 995   stg_stats <- readIORef opt_StgStats
 996   let stg_stats_flag | stg_stats = "-dstg-stats"
 997                      | otherwise = ""
 998
 999   let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
1000         -- let-no-escape always on for now
1001
1002   verb <- is_verbose
1003   let hi_vers = "-fhi-version="++cProjectVersionInt
1004   static <- (do s <- readIORef static; if s then return "-static" else return "")
1005
1006   l <- readIORef hsc_lang
1007   let lang = case l of
1008                 HscC    -> "-olang=C"
1009                 HscAsm  -> "-olang=asm"
1010                 HscJava -> "-olang=java"
1011
1012   -- get hi-file suffix
1013   hisuf <- readIORef hi_suf
1014
1015   -- hi-suffix for packages depends on the build tag.
1016   package_hisuf <-
1017         do tag <- readIORef build_tag
1018            if null tag
1019                 then return "hi"
1020                 else return (tag ++ "_hi")
1021
1022   import_dirs <- readIORef import_paths
1023   package_import_dirs <- getPackageImportPath
1024
1025   let hi_map = "-himap=" ++
1026                 makeHiMap import_dirs hisuf
1027                          package_import_dirs package_hisuf
1028                          split_marker
1029
1030       hi_map_sep = "-himap-sep=" ++ [split_marker]
1031
1032   scale <- readIORef scale_sizes_by
1033   heap  <- readState specific_heap_size
1034   stack <- readState specific_stack_size
1035   cmdline_rts_opts <- getOpts opt_Crts
1036   let heap'  = truncate (fromIntegral heap  * scale) :: Integer
1037       stack' = truncate (fromIntegral stack * scale) :: Integer
1038       rts_opts = [ "+RTS", "-H"++show heap', "-K"++show stack' ]
1039                  ++ cmdline_rts_opts ++ [ "-RTS" ]
1040
1041   -- take into account -fno-* flags by removing the equivalent -f*
1042   -- flag from our list.
1043   anti_flags <- getOpts anti_opt_C
1044   let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
1045       filtered_opts = filter (`notElem` anti_flags) basic_opts
1046
1047   return
1048         (
1049         filtered_opts
1050         -- ToDo: C stub files
1051         ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
1052         ++ rts_opts
1053         )
1054
1055 makeHiMap
1056   (import_dirs         :: [String])
1057   (hi_suffix           :: String)
1058   (package_import_dirs :: [String])
1059   (package_hi_suffix   :: String)
1060   (split_marker        :: Char)
1061   = foldr (add_dir hi_suffix)
1062         (foldr (add_dir package_hi_suffix) "" package_import_dirs)
1063         import_dirs
1064   where
1065      add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
1066
1067
1068 getOptionsFromSource
1069         :: String               -- input file
1070         -> IO [String]          -- options, if any
1071 getOptionsFromSource file
1072   = do h <- openFile file ReadMode
1073        catchJust ioErrors (look h)
1074           (\e -> if isEOFError e then return [] else ioError e)
1075   where
1076         look h = do
1077             l <- hGetLine h
1078             case () of
1079                 () | null l -> look h
1080                    | prefixMatch "#" l -> look h
1081                    | prefixMatch "{-# LINE" l -> look h   -- -}
1082                    | Just (opts:_) <- matchRegex optionRegex l
1083                         -> return (words opts)
1084                    | otherwise -> return []
1085
1086 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
1087
1088 -----------------------------------------------------------------------------
1089 -- Main loop
1090
1091 get_source_files :: [String] -> ([String],[String])
1092 get_source_files = partition (('-' /=) . head)
1093
1094 main =
1095   -- all error messages are propagated as exceptions
1096   my_catchDyn (\dyn -> case dyn of
1097                           PhaseFailed _phase code -> exitWith code
1098                           Interrupted -> exitWith (ExitFailure 1)
1099                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
1100                                   exitWith (ExitFailure 1)
1101               ) $
1102
1103   later cleanTempFiles $
1104         -- exceptions will be blocked while we clean the temporary files,
1105         -- so there shouldn't be any difficulty if we receive further
1106         -- signals.
1107
1108   do
1109         -- install signal handlers
1110    main_thread <- myThreadId
1111
1112 #ifndef mingw32_TARGET_OS
1113    let sig_handler = Catch (raiseInThread main_thread
1114                                 (DynException (toDyn Interrupted)))
1115    installHandler sigQUIT sig_handler Nothing
1116    installHandler sigINT  sig_handler Nothing
1117 #endif
1118
1119    pgm    <- getProgName
1120    writeIORef prog_name pgm
1121
1122    argv   <- getArgs
1123
1124         -- grab any -B options from the command line first
1125    argv'  <- setTopDir argv
1126
1127         -- check whether TMPDIR is set in the environment
1128 #ifndef mingw32_TARGET_OS
1129    IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
1130               writeIORef tmpdir dir)
1131 #endif
1132
1133         -- read the package configuration
1134    conf_file <- readIORef package_config
1135    contents <- readFile conf_file
1136    writeIORef package_details (read contents)
1137
1138         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
1139    (flags2, todo, stop_flag) <- getToDo argv'
1140    writeIORef v_todo todo
1141
1142         -- process all the other arguments, and get the source files
1143    srcs <- processArgs driver_opts flags2 []
1144
1145         -- find the build tag, and re-process the build-specific options
1146    more_opts <- findBuildTag
1147    _ <- processArgs driver_opts more_opts []
1148
1149         -- get the -v flag
1150    verb <- readIORef verbose
1151
1152    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
1153
1154         -- mkdependHS is special
1155    when (todo == DoMkDependHS) beginMkDependHS
1156
1157         -- for each source file, find which phases to run
1158    pipelines <- mapM (genPipeline todo stop_flag) srcs
1159    let src_pipelines = zip srcs pipelines
1160
1161    o_file <- readIORef output_file
1162    if isJust o_file && todo /= DoLink && length srcs > 1
1163         then throwDyn (UsageError "can't apply -o option to multiple source files")
1164         else do
1165
1166    if null srcs then throwDyn (UsageError "no input files") else do
1167
1168         -- save the flag state, because this could be modified by OPTIONS pragmas
1169         -- during the compilation, and we'll need to restore it before starting
1170         -- the next compilation.
1171    saved_driver_state <- readIORef driver_state
1172
1173    let compileFile (src, phases) = do
1174           r <- run_pipeline phases src (todo==DoLink) True orig_base orig_suff
1175           writeIORef driver_state saved_driver_state
1176           return r
1177           where (orig_base, orig_suff) = splitFilename src
1178
1179    o_files <- mapM compileFile src_pipelines
1180
1181    when (todo == DoMkDependHS) endMkDependHS
1182
1183    when (todo == DoLink) (do_link o_files)
1184
1185
1186 -----------------------------------------------------------------------------
1187 -- Which phase to stop at
1188
1189 data ToDo = DoMkDependHS | StopBefore Phase | DoLink
1190   deriving (Eq)
1191
1192 GLOBAL_VAR(v_todo, error "todo", ToDo)
1193
1194 todoFlag :: String -> Maybe ToDo
1195 todoFlag "-M" = Just $ DoMkDependHS
1196 todoFlag "-E" = Just $ StopBefore Hsc
1197 todoFlag "-C" = Just $ StopBefore HCc
1198 todoFlag "-S" = Just $ StopBefore As
1199 todoFlag "-c" = Just $ StopBefore Ln
1200 todoFlag _    = Nothing
1201
1202 getToDo :: [String]
1203          -> IO ( [String]   -- rest of command line
1204                , ToDo       -- phase to stop at
1205                , String     -- "stop at" flag
1206                )
1207 getToDo flags
1208   = case my_partition todoFlag flags of
1209         ([]   , rest) -> return (rest, DoLink,  "") -- default is to do linking
1210         ([(flag,one)], rest) -> return (rest, one, flag)
1211         (_    , _   ) ->
1212           throwDyn (OtherError "only one of the flags -M, -E, -C, -S, -c is allowed")
1213
1214 -----------------------------------------------------------------------------
1215 -- genPipeline
1216 --
1217 -- Herein is all the magic about which phases to run in which order, whether
1218 -- the intermediate files should be in /tmp or in the current directory,
1219 -- what the suffix of the intermediate files should be, etc.
1220
1221 -- The following compilation pipeline algorithm is fairly hacky.  A
1222 -- better way to do this would be to express the whole compilation as a
1223 -- data flow DAG, where the nodes are the intermediate files and the
1224 -- edges are the compilation phases.  This framework would also work
1225 -- nicely if a Haskell dependency generator were included in the
1226 -- driver.
1227
1228 -- It would also deal much more cleanly with compilation phases that
1229 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
1230 -- possibly stub files), where some of the output files need to be
1231 -- processed further (eg. the stub files need to be compiled by the C
1232 -- compiler).
1233
1234 -- A cool thing to do would then be to execute the data flow graph
1235 -- concurrently, automatically taking advantage of extra processors on
1236 -- the host machine.  For example, when compiling two Haskell files
1237 -- where one depends on the other, the data flow graph would determine
1238 -- that the C compiler from the first comilation can be overlapped
1239 -- with the hsc compilation for the second file.
1240
1241 data IntermediateFileType
1242   = Temporary
1243   | Persistent
1244   deriving (Eq)
1245
1246 -- the first compilation phase for a given file is determined
1247 -- by its suffix.
1248 startPhase "lhs"   = Unlit
1249 startPhase "hs"    = Cpp
1250 startPhase "hc"    = HCc
1251 startPhase "c"     = Cc
1252 startPhase "raw_s" = Mangle
1253 startPhase "s"     = As
1254 startPhase "S"     = As
1255 startPhase "o"     = Ln
1256 startPhase _       = Ln    -- all unknown file types
1257
1258 genPipeline
1259    :: ToDo              -- when to stop
1260    -> String            -- "stop after" flag (for error messages)
1261    -> String            -- original filename
1262    -> IO [              -- list of phases to run for this file
1263              (Phase,
1264               IntermediateFileType,  -- keep the output from this phase?
1265               String)                -- output file suffix
1266          ]
1267
1268 genPipeline todo stop_flag filename
1269  = do
1270    split      <- readIORef split_object_files
1271    mangle     <- readIORef do_asm_mangling
1272    lang       <- readIORef hsc_lang
1273    keep_hc    <- readIORef keep_hc_files
1274    keep_raw_s <- readIORef keep_raw_s_files
1275    keep_s     <- readIORef keep_s_files
1276
1277    let
1278    ----------- -----  ----   ---   --   --  -  -  -
1279     (_basename, suffix) = splitFilename filename
1280
1281     start_phase = startPhase suffix
1282
1283     haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ]
1284     c_ish_file       = suffix `elem` [ "c", "s", "S" ]  -- maybe .cc et al.??
1285
1286    -- for a .hc file, or if the -C flag is given, we need to force lang to HscC
1287     real_lang
1288         | suffix == "hc"  = HscC
1289         | todo == StopBefore HCc && lang /= HscC && haskell_ish_file = HscC
1290         | otherwise = lang
1291
1292    let
1293    ----------- -----  ----   ---   --   --  -  -  -
1294     pipeline
1295       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
1296
1297       | haskell_ish_file =
1298        case real_lang of
1299         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
1300                                         SplitMangle, SplitAs ]
1301                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
1302                 | split           -> not_valid
1303                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
1304
1305         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
1306                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
1307
1308         HscJava | split           -> not_valid
1309                 | otherwise       -> error "not implemented: compiling via Java"
1310
1311       | c_ish_file      = [ Cc, As ]
1312
1313       | otherwise       = [ ]  -- just pass this file through to the linker
1314
1315         -- ToDo: this is somewhat cryptic
1316     not_valid = throwDyn (OtherError ("invalid option combination"))
1317    ----------- -----  ----   ---   --   --  -  -  -
1318
1319         -- this shouldn't happen.
1320    if start_phase /= Ln && start_phase `notElem` pipeline
1321         then throwDyn (OtherError ("can't find starting phase for "
1322                                     ++ filename))
1323         else do
1324
1325         -- if we can't find the phase we're supposed to stop before,
1326         -- something has gone wrong.
1327    case todo of
1328         StopBefore phase ->
1329            when (phase /= Ln
1330                  && phase `notElem` pipeline
1331                  && not (phase == As && SplitAs `elem` pipeline)) $
1332               throwDyn (OtherError
1333                 ("flag " ++ stop_flag
1334                  ++ " is incompatible with source file `" ++ filename ++ "'"))
1335         _ -> return ()
1336
1337    let
1338    ----------- -----  ----   ---   --   --  -  -  -
1339       annotatePipeline
1340          :: [Phase]             -- raw pipeline
1341          -> Phase               -- phase to stop before
1342          -> [(Phase, IntermediateFileType, String{-file extension-})]
1343       annotatePipeline []     _    = []
1344       annotatePipeline (Ln:_) _    = []
1345       annotatePipeline (phase:next_phase:ps) stop =
1346           (phase, keep_this_output, phase_input_ext next_phase)
1347              : annotatePipeline (next_phase:ps) stop
1348           where
1349                 keep_this_output
1350                      | next_phase == stop = Persistent
1351                      | otherwise =
1352                         case next_phase of
1353                              Ln -> Persistent
1354                              Mangle | keep_raw_s -> Persistent
1355                              As     | keep_s     -> Persistent
1356                              HCc    | keep_hc    -> Persistent
1357                              _other              -> Temporary
1358
1359         -- add information about output files to the pipeline
1360         -- the suffix on an output file is determined by the next phase
1361         -- in the pipeline, so we add linking to the end of the pipeline
1362         -- to force the output from the final phase to be a .o file.
1363       stop_phase = case todo of StopBefore phase -> phase
1364                                 DoMkDependHS     -> Ln
1365                                 DoLink           -> Ln
1366       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
1367
1368       phase_ne p (p1,_,_) = (p1 /= p)
1369    ----------- -----  ----   ---   --   --  -  -  -
1370
1371    return $
1372      dropWhile (phase_ne start_phase) .
1373         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
1374                 $ annotated_pipeline
1375
1376
1377
1378 -- the output suffix for a given phase is uniquely determined by
1379 -- the input requirements of the next phase.
1380 phase_input_ext Unlit       = "lhs"
1381 phase_input_ext Cpp         = "lpp"
1382 phase_input_ext Hsc         = "cpp"
1383 phase_input_ext HCc         = "hc"
1384 phase_input_ext Cc          = "c"
1385 phase_input_ext Mangle      = "raw_s"
1386 phase_input_ext SplitMangle = "split_s" -- not really generated
1387 phase_input_ext As          = "s"
1388 phase_input_ext SplitAs     = "split_s" -- not really generated
1389 phase_input_ext Ln          = "o"
1390 phase_input_ext MkDependHS  = "dep"
1391
1392 run_pipeline
1393   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
1394   -> String                     -- input file
1395   -> Bool                       -- doing linking afterward?
1396   -> Bool                       -- take into account -o when generating output?
1397   -> String                     -- original basename (eg. Main)
1398   -> String                     -- original suffix   (eg. hs)
1399   -> IO String                  -- return final filename
1400
1401 run_pipeline [] input_fn _ _ _ _ = return input_fn
1402 run_pipeline ((phase, keep, o_suffix):phases)
1403         input_fn do_linking use_ofile orig_basename orig_suffix
1404   = do
1405
1406      output_fn <- outputFileName (null phases) keep o_suffix
1407
1408      carry_on <- run_phase phase orig_basename orig_suffix input_fn output_fn
1409         -- sometimes we bail out early, eg. when the compiler's recompilation
1410         -- checker has determined that recompilation isn't necessary.
1411      if not carry_on
1412         then do let (_,keep,final_suffix) = last phases
1413                 ofile <- outputFileName True keep final_suffix
1414                 return ofile
1415         else do -- carry on ...
1416
1417         -- sadly, ghc -E is supposed to write the file to stdout.  We
1418         -- generate <file>.cpp, so we also have to cat the file here.
1419      when (null phases && phase == Cpp) $
1420         run_something "Dump pre-processed file to stdout"
1421                       ("cat " ++ output_fn)
1422
1423      run_pipeline phases output_fn do_linking use_ofile orig_basename orig_suffix
1424
1425   where
1426      outputFileName last_phase keep suffix
1427         = do o_file <- readIORef output_file
1428              if last_phase && not do_linking && use_ofile && isJust o_file
1429                then case o_file of
1430                        Just s  -> return s
1431                        Nothing -> error "outputFileName"
1432                else if keep == Persistent
1433                            then do f <- odir_ify (orig_basename ++ '.':suffix)
1434                                    osuf_ify f
1435                            else do filename <- newTempName suffix
1436                                    add files_to_clean filename
1437                                    return filename
1438
1439 -- find a temporary name that doesn't already exist.
1440 newTempName :: String -> IO String
1441 newTempName extn = do
1442   x <- getProcessID
1443   tmp_dir <- readIORef tmpdir
1444   findTempName tmp_dir x
1445   where findTempName tmp_dir x = do
1446            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1447            b  <- doesFileExist filename
1448            if b then findTempName tmp_dir (x+1)
1449                 else return filename
1450
1451 -------------------------------------------------------------------------------
1452 -- mkdependHS
1453
1454         -- flags
1455 GLOBAL_VAR(dep_makefile,        "Makefile", String);
1456 GLOBAL_VAR(dep_include_prelude, False, Bool);
1457 GLOBAL_VAR(dep_ignore_dirs,     [], [String]);
1458 GLOBAL_VAR(dep_suffixes,        [], [String]);
1459 GLOBAL_VAR(dep_warnings,        True, Bool);
1460
1461         -- global vars
1462 GLOBAL_VAR(dep_makefile_hdl,    error "dep_makefile_hdl", Maybe Handle);
1463 GLOBAL_VAR(dep_tmp_file,        error "dep_tmp_file", String);
1464 GLOBAL_VAR(dep_tmp_hdl,         error "dep_tmp_hdl", Handle);
1465 GLOBAL_VAR(dep_dir_contents,    error "dep_dir_contents", [(String,[String])]);
1466
1467 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
1468 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
1469
1470 -- for compatibility with the old mkDependHS, we accept options of the form
1471 -- -optdep-f -optdep.depend, etc.
1472 dep_opts = [
1473    (  "s",                      SepArg (add dep_suffixes) ),
1474    (  "f",                      SepArg (writeIORef dep_makefile) ),
1475    (  "w",                      NoArg (writeIORef dep_warnings False) ),
1476    (  "-include-prelude",       NoArg (writeIORef dep_include_prelude True) ),
1477    (  "X",                      Prefix (addToDirList dep_ignore_dirs) ),
1478    (  "-exclude-directory=",    Prefix (addToDirList dep_ignore_dirs) )
1479  ]
1480
1481 beginMkDependHS :: IO ()
1482 beginMkDependHS = do
1483
1484         -- slurp in the mkdependHS-style options
1485   flags <- getOpts opt_dep
1486   _ <- processArgs dep_opts flags []
1487
1488         -- open a new temp file in which to stuff the dependency info
1489         -- as we go along.
1490   dep_file <- newTempName "dep"
1491   add files_to_clean dep_file
1492   writeIORef dep_tmp_file dep_file
1493   tmp_hdl <- openFile dep_file WriteMode
1494   writeIORef dep_tmp_hdl tmp_hdl
1495
1496         -- open the makefile
1497   makefile <- readIORef dep_makefile
1498   exists <- doesFileExist makefile
1499   if not exists
1500         then do
1501            writeIORef dep_makefile_hdl Nothing
1502            return ()
1503
1504         else do
1505            makefile_hdl <- openFile makefile ReadMode
1506            writeIORef dep_makefile_hdl (Just makefile_hdl)
1507
1508                 -- slurp through until we get the magic start string,
1509                 -- copying the contents into dep_makefile
1510            let slurp = do
1511                 l <- hGetLine makefile_hdl
1512                 if (l == depStartMarker)
1513                         then return ()
1514                         else do hPutStrLn tmp_hdl l; slurp
1515
1516                 -- slurp through until we get the magic end marker,
1517                 -- throwing away the contents
1518            let chuck = do
1519                 l <- hGetLine makefile_hdl
1520                 if (l == depEndMarker)
1521                         then return ()
1522                         else chuck
1523
1524            catchJust ioErrors slurp
1525                 (\e -> if isEOFError e then return () else ioError e)
1526            catchJust ioErrors chuck
1527                 (\e -> if isEOFError e then return () else ioError e)
1528
1529
1530         -- write the magic marker into the tmp file
1531   hPutStrLn tmp_hdl depStartMarker
1532
1533         -- cache the contents of all the import directories, for future
1534         -- reference.
1535   import_dirs <- readIORef import_paths
1536   pkg_import_dirs <- getPackageImportPath
1537   import_dir_contents <- mapM getDirectoryContents import_dirs
1538   pkg_import_dir_contents <- mapM getDirectoryContents pkg_import_dirs
1539   writeIORef dep_dir_contents
1540         (zip import_dirs import_dir_contents ++
1541          zip pkg_import_dirs pkg_import_dir_contents)
1542
1543         -- ignore packages unless --include-prelude is on
1544   include_prelude <- readIORef dep_include_prelude
1545   when (not include_prelude) $
1546     mapM_ (add dep_ignore_dirs) pkg_import_dirs
1547
1548   return ()
1549
1550
1551 endMkDependHS :: IO ()
1552 endMkDependHS = do
1553   makefile     <- readIORef dep_makefile
1554   makefile_hdl <- readIORef dep_makefile_hdl
1555   tmp_file     <- readIORef dep_tmp_file
1556   tmp_hdl      <- readIORef dep_tmp_hdl
1557
1558         -- write the magic marker into the tmp file
1559   hPutStrLn tmp_hdl depEndMarker
1560
1561   case makefile_hdl of
1562      Nothing  -> return ()
1563      Just hdl -> do
1564
1565           -- slurp the rest of the orignal makefile and copy it into the output
1566         let slurp = do
1567                 l <- hGetLine hdl
1568                 hPutStrLn tmp_hdl l
1569                 slurp
1570
1571         catchJust ioErrors slurp
1572                 (\e -> if isEOFError e then return () else ioError e)
1573
1574         hClose hdl
1575
1576   hClose tmp_hdl  -- make sure it's flushed
1577
1578         -- create a backup of the original makefile
1579   when (isJust makefile_hdl) $
1580      run_something ("Backing up " ++ makefile)
1581         (unwords [ "cp", makefile, makefile++".bak" ])
1582
1583         -- copy the new makefile in place
1584   run_something "Installing new makefile"
1585         (unwords [ "cp", tmp_file, makefile ])
1586
1587
1588 findDependency :: String -> Import -> IO (Maybe (String, Bool))
1589 findDependency mod imp = do
1590    dir_contents <- readIORef dep_dir_contents
1591    ignore_dirs  <- readIORef dep_ignore_dirs
1592    hisuf <- readIORef hi_suf
1593
1594    let
1595      (imp_mod, is_source) =
1596         case imp of
1597            Normal str -> (str, False)
1598            Source str -> (str, True )
1599
1600      imp_hi = imp_mod ++ '.':hisuf
1601      imp_hiboot = imp_mod ++ ".hi-boot"
1602      imp_hiboot_v = imp_mod ++ ".hi-boot-" ++ cHscIfaceFileVersion
1603      imp_hs = imp_mod ++ ".hs"
1604      imp_lhs = imp_mod ++ ".lhs"
1605
1606      deps | is_source = [ imp_hiboot_v, imp_hiboot, imp_hs, imp_lhs ]
1607           | otherwise = [ imp_hi, imp_hs, imp_lhs ]
1608
1609      search [] = throwDyn (OtherError ("can't find one of the following: " ++
1610                                       unwords (map (\d -> '`': d ++ "'") deps) ++
1611                                       " (imported from `" ++ mod ++ "')"))
1612      search ((dir, contents) : dirs)
1613            | null present = search dirs
1614            | otherwise =
1615                 if dir `elem` ignore_dirs
1616                         then return Nothing
1617                         else if is_source
1618                                 then if dep /= imp_hiboot_v
1619                                         then return (Just (dir++'/':imp_hiboot, False))
1620                                         else return (Just (dir++'/':dep, False))
1621                                 else return (Just (dir++'/':imp_hi, not is_source))
1622            where
1623                 present = filter (`elem` contents) deps
1624                 dep     = head present
1625
1626    -- in
1627    search dir_contents
1628
1629
1630 -------------------------------------------------------------------------------
1631 -- Unlit phase
1632
1633 run_phase Unlit _basename _suff input_fn output_fn
1634   = do unlit <- readIORef pgm_L
1635        unlit_flags <- getOpts opt_L
1636        run_something "Literate pre-processor"
1637           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
1638            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1639        return True
1640
1641 -------------------------------------------------------------------------------
1642 -- Cpp phase
1643
1644 run_phase Cpp _basename _suff input_fn output_fn
1645   = do src_opts <- getOptionsFromSource input_fn
1646         -- ToDo: this is *wrong* if we're processing more than one file:
1647         -- the OPTIONS will persist through the subsequent compilations.
1648        _ <- processArgs driver_opts src_opts []
1649
1650        do_cpp <- readState cpp_flag
1651        if do_cpp
1652           then do
1653             cpp <- readIORef pgm_P
1654             hscpp_opts <- getOpts opt_P
1655             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1656
1657             cmdline_include_paths <- readIORef include_paths
1658             pkg_include_dirs <- getPackageIncludePath
1659             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
1660                                                         ++ pkg_include_dirs)
1661
1662             verb <- is_verbose
1663             run_something "C pre-processor"
1664                 (unwords
1665                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
1666                      cpp, verb]
1667                     ++ include_paths
1668                     ++ hs_src_cpp_opts
1669                     ++ hscpp_opts
1670                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
1671                    ))
1672           else do
1673             run_something "Ineffective C pre-processor"
1674                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
1675                     ++ output_fn ++ " && cat " ++ input_fn
1676                     ++ " >> " ++ output_fn)
1677        return True
1678
1679 -----------------------------------------------------------------------------
1680 -- MkDependHS phase
1681
1682 run_phase MkDependHS basename suff input_fn _output_fn = do
1683    src <- readFile input_fn
1684    let imports = getImports src
1685
1686    deps <- mapM (findDependency basename) imports
1687
1688    osuf_opt <- readIORef output_suf
1689    let osuf = case osuf_opt of
1690                         Nothing -> "o"
1691                         Just s  -> s
1692
1693    extra_suffixes <- readIORef dep_suffixes
1694    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
1695        ofiles = map (\suf -> basename ++ '.':suf) suffixes
1696
1697    objs <- mapM odir_ify ofiles
1698
1699    hdl <- readIORef dep_tmp_hdl
1700
1701         -- std dependeny of the object(s) on the source file
1702    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
1703
1704    let genDep (dep, False {- not an hi file -}) =
1705           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
1706        genDep (dep, True  {- is an hi file -}) = do
1707           hisuf <- readIORef hi_suf
1708           let dep_base = remove_suffix '.' dep
1709               deps = (dep_base ++ hisuf)
1710                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
1711                   -- length objs should be == length deps
1712           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
1713
1714    mapM genDep [ d | Just d <- deps ]
1715
1716    return True
1717
1718 -- add the lines to dep_makefile:
1719            -- always:
1720                    -- this.o : this.hs
1721
1722            -- if the dependency is on something other than a .hi file:
1723                    -- this.o this.p_o ... : dep
1724            -- otherwise
1725                    -- if the import is {-# SOURCE #-}
1726                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
1727
1728                    -- else
1729                            -- this.o ...   : dep.hi
1730                            -- this.p_o ... : dep.p_hi
1731                            -- ...
1732
1733            -- (where .o is $osuf, and the other suffixes come from
1734            -- the cmdline -s options).
1735
1736 -----------------------------------------------------------------------------
1737 -- Hsc phase
1738
1739 run_phase Hsc   basename suff input_fn output_fn
1740   = do  hsc <- readIORef pgm_C
1741
1742   -- we add the current directory (i.e. the directory in which
1743   -- the .hs files resides) to the import path, since this is
1744   -- what gcc does, and it's probably what you want.
1745         let current_dir = getdir basename
1746
1747         paths <- readIORef include_paths
1748         writeIORef include_paths (current_dir : paths)
1749
1750   -- build the hsc command line
1751         hsc_opts <- build_hsc_opts
1752
1753   -- deal with -Rghc-timing
1754         timing <- readIORef collect_ghc_timing
1755         stat_file <- newTempName "stat"
1756         add files_to_clean stat_file
1757         let stat_opts | timing    = [ "+RTS", "-S"++stat_file, "-RTS" ]
1758                       | otherwise = []
1759
1760   -- tmp files for foreign export stub code
1761         tmp_stub_h <- newTempName "stub_h"
1762         tmp_stub_c <- newTempName "stub_c"
1763         add files_to_clean tmp_stub_h
1764         add files_to_clean tmp_stub_c
1765
1766   -- figure out where to put the .hi file
1767         ohi    <- readIORef output_hi
1768         hisuf  <- readIORef hi_suf
1769         let hi_flags = case ohi of
1770                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
1771                            Just fn -> [ "-hifile="++fn ]
1772
1773   -- figure out if the source has changed, for recompilation avoidance.
1774   -- only do this if we're eventually going to generate a .o file.
1775   -- (ToDo: do when generating .hc files too?)
1776   --
1777   -- Setting source_unchanged to "-fsource_unchanged" means that M.o seems
1778   -- to be up to date wrt M.hs; so no need to recompile unless imports have
1779   -- changed (which the compiler itself figures out).
1780   -- Setting source_unchanged to "" tells the compiler that M.o is out of
1781   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
1782         do_recomp <- readIORef recomp
1783         todo <- readIORef v_todo
1784         o_file' <- odir_ify (basename ++ '.':phase_input_ext Ln)
1785         o_file <- osuf_ify o_file'
1786         source_unchanged <-
1787           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
1788              then return ""
1789              else do t1 <- getModificationTime (basename ++ '.':suff)
1790                      o_file_exists <- doesFileExist o_file
1791                      if not o_file_exists
1792                         then return ""  -- Need to recompile
1793                         else do t2 <- getModificationTime o_file
1794                                 if t2 > t1
1795                                   then return "-fsource-unchanged"
1796                                   else return ""
1797
1798   -- run the compiler!
1799         run_something "Haskell Compiler"
1800                  (unwords (hsc : input_fn : (
1801                     hsc_opts
1802                     ++ hi_flags
1803                     ++ [
1804                           source_unchanged,
1805                           "-ofile="++output_fn,
1806                           "-F="++tmp_stub_c,
1807                           "-FH="++tmp_stub_h
1808                        ]
1809                     ++ stat_opts
1810                  )))
1811
1812   -- check whether compilation was performed, bail out if not
1813         b <- doesFileExist output_fn
1814         if not b && not (null source_unchanged) -- sanity
1815                 then do run_something "Touching object file"
1816                             ("touch " ++ o_file)
1817                         return False
1818                 else do -- carry on...
1819
1820   -- Generate -Rghc-timing info
1821         when (timing) (
1822             run_something "Generate timing stats"
1823                 (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
1824          )
1825
1826   -- Deal with stubs
1827         let stub_h = basename ++ "_stub.h"
1828         let stub_c = basename ++ "_stub.c"
1829
1830                 -- copy .h_stub file into current dir if present
1831         b <- doesFileExist tmp_stub_h
1832         when b (do
1833                 run_something "Copy stub .h file"
1834                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1835
1836                         -- #include <..._stub.h> in .hc file
1837                 addCmdlineHCInclude tmp_stub_h  -- hack
1838
1839                         -- copy the _stub.c file into the current dir
1840                 run_something "Copy stub .c file"
1841                     (unwords [
1842                         "rm -f", stub_c, "&&",
1843                         "echo \'#include \"Stg.h\"\n#include \""++stub_h++"\"\' >"++stub_c, " &&",
1844                         "cat", tmp_stub_c, ">> ", stub_c
1845                         ])
1846
1847                         -- compile the _stub.c file w/ gcc
1848                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
1849                 run_pipeline pipeline stub_c False{-no linking-}
1850                                 False{-no -o option-}
1851                                 (basename++"_stub") "c"
1852
1853                 add ld_inputs (basename++"_stub.o")
1854          )
1855         return True
1856
1857 -----------------------------------------------------------------------------
1858 -- Cc phase
1859
1860 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
1861 -- way too many hacks, and I can't say I've ever used it anyway.
1862
1863 run_phase cc_phase _basename _suff input_fn output_fn
1864    | cc_phase == Cc || cc_phase == HCc
1865    = do cc <- readIORef pgm_c
1866         cc_opts <- (getOpts opt_c)
1867         cmdline_include_dirs <- readIORef include_paths
1868
1869         let hcc = cc_phase == HCc
1870
1871                 -- add package include paths even if we're just compiling
1872                 -- .c files; this is the Value Add(TM) that using
1873                 -- ghc instead of gcc gives you :)
1874         pkg_include_dirs <- getPackageIncludePath
1875         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
1876                                                         ++ pkg_include_dirs)
1877
1878         c_includes <- getPackageCIncludes
1879         cmdline_includes <- readState cmdline_hc_includes -- -#include options
1880
1881         let cc_injects | hcc = unlines (map mk_include
1882                                         (c_includes ++ reverse cmdline_includes))
1883                        | otherwise = ""
1884             mk_include h_file =
1885                 case h_file of
1886                    '"':_{-"-} -> "#include "++h_file
1887                    '<':_      -> "#include "++h_file
1888                    _          -> "#include \""++h_file++"\""
1889
1890         cc_help <- newTempName "c"
1891         add files_to_clean cc_help
1892         h <- openFile cc_help WriteMode
1893         hPutStr h cc_injects
1894         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1895         hClose h
1896
1897         ccout <- newTempName "ccout"
1898         add files_to_clean ccout
1899
1900         mangle <- readIORef do_asm_mangling
1901         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1902
1903         verb <- is_verbose
1904
1905         o2 <- readIORef opt_minus_o2_for_C
1906         let opt_flag | o2        = "-O2"
1907                      | otherwise = "-O"
1908
1909         pkg_extra_cc_opts <- getPackageExtraCcOpts
1910
1911         excessPrecision <- readState excess_precision
1912
1913         run_something "C Compiler"
1914          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1915                    ++ md_c_flags
1916                    ++ (if cc_phase == HCc && mangle
1917                          then md_regd_c_flags
1918                          else [])
1919                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1920                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1921                    ++ cc_opts
1922                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
1923                    ++ include_paths
1924                    ++ pkg_extra_cc_opts
1925 --                 ++ [">", ccout]
1926                    ))
1927         return True
1928
1929         -- ToDo: postprocess the output from gcc
1930
1931 -----------------------------------------------------------------------------
1932 -- Mangle phase
1933
1934 run_phase Mangle _basename _suff input_fn output_fn
1935   = do mangler <- readIORef pgm_m
1936        mangler_opts <- getOpts opt_m
1937        machdep_opts <-
1938          if (prefixMatch "i386" cTARGETPLATFORM)
1939             then do n_regs <- readState stolen_x86_regs
1940                     return [ show n_regs ]
1941             else return []
1942        run_something "Assembly Mangler"
1943         (unwords (mangler :
1944                      mangler_opts
1945                   ++ [ input_fn, output_fn ]
1946                   ++ machdep_opts
1947                 ))
1948        return True
1949
1950 -----------------------------------------------------------------------------
1951 -- Splitting phase
1952
1953 run_phase SplitMangle _basename _suff input_fn _output_fn
1954   = do  splitter <- readIORef pgm_s
1955
1956         -- this is the prefix used for the split .s files
1957         tmp_pfx <- readIORef tmpdir
1958         x <- getProcessID
1959         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1960         writeIORef split_prefix split_s_prefix
1961         add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1962
1963         -- allocate a tmp file to put the no. of split .s files in (sigh)
1964         n_files <- newTempName "n_files"
1965         add files_to_clean n_files
1966
1967         run_something "Split Assembly File"
1968          (unwords [ splitter
1969                   , input_fn
1970                   , split_s_prefix
1971                   , n_files ]
1972          )
1973
1974         -- save the number of split files for future references
1975         s <- readFile n_files
1976         let n = read s :: Int
1977         writeIORef n_split_files n
1978         return True
1979
1980 -----------------------------------------------------------------------------
1981 -- As phase
1982
1983 run_phase As _basename _suff input_fn output_fn
1984   = do  as <- readIORef pgm_a
1985         as_opts <- getOpts opt_a
1986
1987         cmdline_include_paths <- readIORef include_paths
1988         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1989         run_something "Assembler"
1990            (unwords (as : as_opts
1991                        ++ cmdline_include_flags
1992                        ++ [ "-c", input_fn, "-o",  output_fn ]
1993                     ))
1994         return True
1995
1996 run_phase SplitAs basename _suff _input_fn _output_fn
1997   = do  as <- readIORef pgm_a
1998         as_opts <- getOpts opt_a
1999
2000         split_s_prefix <- readIORef split_prefix
2001         n <- readIORef n_split_files
2002
2003         odir <- readIORef output_dir
2004         let real_odir = case odir of
2005                                 Nothing -> basename
2006                                 Just d  -> d
2007
2008         let assemble_file n = do
2009                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
2010                     let output_o = newdir real_odir
2011                                         (basename ++ "__" ++ show n ++ ".o")
2012                     real_o <- osuf_ify output_o
2013                     run_something "Assembler"
2014                             (unwords (as : as_opts
2015                                       ++ [ "-c", "-o", real_o, input_s ]
2016                             ))
2017
2018         mapM_ assemble_file [1..n]
2019         return True
2020
2021 -----------------------------------------------------------------------------
2022 -- Linking
2023
2024 GLOBAL_VAR(no_hs_main, False, Bool)
2025
2026 do_link :: [String] -> IO ()
2027 do_link o_files = do
2028     ln <- readIORef pgm_l
2029     verb <- is_verbose
2030     static <- readIORef static
2031     let imp = if static then "" else "_imp"
2032     no_hs_main <- readIORef no_hs_main
2033     o_file <- readIORef output_file
2034     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
2035
2036     pkg_lib_paths <- getPackageLibraryPath
2037     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
2038
2039     lib_paths <- readIORef library_paths
2040     let lib_path_opts = map ("-L"++) lib_paths
2041
2042     pkg_libs <- getPackageLibraries
2043     let pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
2044
2045     libs <- readIORef cmdline_libraries
2046     let lib_opts = map ("-l"++) (reverse libs)
2047          -- reverse because they're added in reverse order from the cmd line
2048
2049     pkg_extra_ld_opts <- getPackageExtraLdOpts
2050
2051         -- probably _stub.o files
2052     extra_ld_inputs <- readIORef ld_inputs
2053
2054         -- opts from -optl-<blah>
2055     extra_ld_opts <- getOpts opt_l
2056
2057     rts_pkg <- getPackageDetails ["rts"]
2058     std_pkg <- getPackageDetails ["std"]
2059 #ifdef mingw32_TARGET_OS
2060     let extra_os = if static || no_hs_main
2061                    then []
2062                    else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
2063                           head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
2064 #endif
2065     (md_c_flags, _) <- machdepCCOpts
2066     run_something "Linker"
2067        (unwords
2068          ([ ln, verb, "-o", output_fn ]
2069          ++ md_c_flags
2070          ++ o_files
2071 #ifdef mingw32_TARGET_OS
2072          ++ extra_os
2073 #endif
2074          ++ extra_ld_inputs
2075          ++ lib_path_opts
2076          ++ lib_opts
2077          ++ pkg_lib_path_opts
2078          ++ pkg_lib_opts
2079          ++ pkg_extra_ld_opts
2080          ++ extra_ld_opts
2081 #ifdef mingw32_TARGET_OS
2082          ++ if static then [ "-u _PrelMain_mainIO_closure" , "-u ___init_PrelMain"] else []
2083 #else
2084          ++ [ "-u PrelMain_mainIO_closure" , "-u __init_PrelMain"]
2085 #endif
2086         )
2087        )
2088
2089 -----------------------------------------------------------------------------
2090 -- Running an external program
2091
2092 run_something phase_name cmd
2093  = do
2094    verb <- readIORef verbose
2095    when verb $ do
2096         putStr phase_name
2097         putStrLn ":"
2098         putStrLn cmd
2099         hFlush stdout
2100
2101    -- test for -n flag
2102    n <- readIORef dry_run
2103    unless n $ do
2104
2105    -- and run it!
2106 #ifndef mingw32_TARGET_OS
2107    exit_code <- system cmd `catchAllIO`
2108                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
2109 #else
2110    tmp <- newTempName "sh"
2111    h <- openFile tmp WriteMode
2112    hPutStrLn h cmd
2113    hClose h
2114    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
2115                    (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
2116    removeFile tmp
2117 #endif
2118
2119    if exit_code /= ExitSuccess
2120         then throwDyn (PhaseFailed phase_name exit_code)
2121         else do when verb (putStr "\n")
2122                 return ()
2123
2124 -----------------------------------------------------------------------------
2125 -- Flags
2126
2127 data OptKind
2128         = NoArg (IO ())                 -- flag with no argument
2129         | HasArg (String -> IO ())      -- flag has an argument (maybe prefix)
2130         | SepArg (String -> IO ())      -- flag has a separate argument
2131         | Prefix (String -> IO ())      -- flag is a prefix only
2132         | OptPrefix (String -> IO ())   -- flag may be a prefix
2133         | AnySuffix (String -> IO ())   -- flag is a prefix, pass whole arg to fn
2134         | PassFlag  (String -> IO ())   -- flag with no arg, pass flag to fn
2135
2136 -- note that ordering is important in the following list: any flag which
2137 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
2138 -- flags further down the list with the same prefix.
2139
2140 driver_opts =
2141   [  ------- help -------------------------------------------------------
2142      ( "?"              , NoArg long_usage)
2143   ,  ( "-help"          , NoArg long_usage)
2144
2145
2146       ------- version ----------------------------------------------------
2147   ,  ( "-version"        , NoArg (do hPutStrLn stdout (cProjectName
2148                                       ++ ", version " ++ version_str)
2149                                      exitWith ExitSuccess))
2150   ,  ( "-numeric-version", NoArg (do hPutStrLn stdout version_str
2151                                      exitWith ExitSuccess))
2152
2153       ------- verbosity ----------------------------------------------------
2154   ,  ( "v"              , NoArg (writeIORef verbose True) )
2155   ,  ( "n"              , NoArg (writeIORef dry_run True) )
2156
2157         ------- recompilation checker --------------------------------------
2158   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
2159   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
2160
2161         ------- ways --------------------------------------------------------
2162   ,  ( "prof"           , NoArg (addNoDups ways WayProf) )
2163   ,  ( "unreg"          , NoArg (addNoDups ways WayUnreg) )
2164   ,  ( "ticky"          , NoArg (addNoDups ways WayTicky) )
2165   ,  ( "parallel"       , NoArg (addNoDups ways WayPar) )
2166   ,  ( "gransim"        , NoArg (addNoDups ways WayGran) )
2167   ,  ( "smp"            , NoArg (addNoDups ways WaySMP) )
2168   ,  ( "debug"          , NoArg (addNoDups ways WayDebug) )
2169         -- ToDo: user ways
2170
2171         ------- Interface files ---------------------------------------------
2172   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
2173   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
2174   ,  ( "hi-diffs"       , NoArg (writeIORef hi_diffs  NormalHiDiffs) )
2175   ,  ( "no-hi-diffs"    , NoArg (writeIORef hi_diffs  NoHiDiffs) )
2176   ,  ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
2177   ,  ( "keep-hi-diffs"  , NoArg (writeIORef keep_hi_diffs True) )
2178         --"hi-with-*"    -> hiw <- readIORef hi_with  (ToDo)
2179
2180         --------- Profiling --------------------------------------------------
2181   ,  ( "auto-dicts"     , NoArg (addOpt_C "-fauto-sccs-on-dicts") )
2182   ,  ( "auto-all"       , NoArg (addOpt_C "-fauto-sccs-on-all-toplevs") )
2183   ,  ( "auto"           , NoArg (addOpt_C "-fauto-sccs-on-exported-toplevs") )
2184   ,  ( "caf-all"        , NoArg (addOpt_C "-fauto-sccs-on-individual-cafs") )
2185          -- "ignore-sccs"  doesn't work  (ToDo)
2186
2187   ,  ( "no-auto-dicts"  , NoArg (addAntiOpt_C "-fauto-sccs-on-dicts") )
2188   ,  ( "no-auto-all"    , NoArg (addAntiOpt_C "-fauto-sccs-on-all-toplevs") )
2189   ,  ( "no-auto"        , NoArg (addAntiOpt_C "-fauto-sccs-on-exported-toplevs") )
2190   ,  ( "no-caf-all"     , NoArg (addAntiOpt_C "-fauto-sccs-on-individual-cafs") )
2191
2192         ------- Miscellaneous -----------------------------------------------
2193   ,  ( "cpp"            , NoArg (updateState (\s -> s{ cpp_flag = True })) )
2194   ,  ( "#include"       , HasArg (addCmdlineHCInclude) )
2195   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
2196   ,  ( "no-hs-main"     , NoArg (writeIORef no_hs_main True) )
2197
2198         ------- Output Redirection ------------------------------------------
2199   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
2200   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
2201   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
2202   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
2203   ,  ( "tmpdir"         , HasArg (writeIORef tmpdir . (++ "/")) )
2204   ,  ( "ohi"            , HasArg (\s -> case s of
2205                                           "-" -> writeIORef hi_on_stdout True
2206                                           _   -> writeIORef output_hi (Just s)) )
2207         -- -odump?
2208
2209   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
2210   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
2211   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
2212   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
2213
2214   ,  ( "split-objs"     , NoArg (if can_split
2215                                     then do writeIORef split_object_files True
2216                                             addOpt_C "-fglobalise-toplev-names"
2217                                             addOpt_c "-DUSE_SPLIT_MARKERS"
2218                                     else hPutStrLn stderr
2219                                             "warning: don't know how to  split \
2220                                             \object files on this architecture"
2221                                 ) )
2222
2223         ------- Include/Import Paths ----------------------------------------
2224   ,  ( "i"              , OptPrefix (addToDirList import_paths) )
2225   ,  ( "I"              , Prefix    (addToDirList include_paths) )
2226
2227         ------- Libraries ---------------------------------------------------
2228   ,  ( "L"              , Prefix (addToDirList library_paths) )
2229   ,  ( "l"              , Prefix (add cmdline_libraries) )
2230
2231         ------- Packages ----------------------------------------------------
2232   ,  ( "package-name"   , HasArg (\s -> addOpt_C ("-inpackage="++s)) )
2233
2234   ,  ( "package"        , HasArg (addPackage) )
2235   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
2236
2237   ,  ( "-list-packages"  , NoArg (listPackages) )
2238   ,  ( "-add-package"    , NoArg (newPackage) )
2239   ,  ( "-delete-package" , SepArg (deletePackage) )
2240
2241         ------- Specific phases  --------------------------------------------
2242   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
2243   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
2244   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
2245   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
2246   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
2247   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
2248   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
2249   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
2250
2251   ,  ( "optdep"         , HasArg (addOpt_dep) )
2252   ,  ( "optL"           , HasArg (addOpt_L) )
2253   ,  ( "optP"           , HasArg (addOpt_P) )
2254   ,  ( "optCrts"        , HasArg (addOpt_Crts) )
2255   ,  ( "optC"           , HasArg (addOpt_C) )
2256   ,  ( "optc"           , HasArg (addOpt_c) )
2257   ,  ( "optm"           , HasArg (addOpt_m) )
2258   ,  ( "opta"           , HasArg (addOpt_a) )
2259   ,  ( "optl"           , HasArg (addOpt_l) )
2260   ,  ( "optdll"         , HasArg (addOpt_dll) )
2261
2262         ------ HsCpp opts ---------------------------------------------------
2263   ,  ( "D"              , Prefix (\s -> addOpt_P ("-D'"++s++"'") ) )
2264   ,  ( "U"              , Prefix (\s -> addOpt_P ("-U'"++s++"'") ) )
2265
2266         ------ Warning opts -------------------------------------------------
2267   ,  ( "W"              , NoArg (updateState (\s -> s{ warning_opt = W_ })))
2268   ,  ( "Wall"           , NoArg (updateState (\s -> s{ warning_opt = W_all })))
2269   ,  ( "Wnot"           , NoArg (updateState (\s -> s{ warning_opt = W_not })))
2270   ,  ( "w"              , NoArg (updateState (\s -> s{ warning_opt = W_not })))
2271
2272         ----- Linker --------------------------------------------------------
2273   ,  ( "static"         , NoArg (writeIORef static True) )
2274   ,  ( "rdynamic"       , NoArg (return ()) ) -- ignored for compat w/ gcc
2275
2276         ------ Compiler RTS options -----------------------------------------
2277   ,  ( "H"                 , HasArg (newHeapSize  . decodeSize) )
2278   ,  ( "K"                 , HasArg (newStackSize . decodeSize) )
2279   ,  ( "Rscale-sizes"      , HasArg (floatOpt scale_sizes_by) )
2280   ,  ( "Rghc-timing"       , NoArg  (writeIORef collect_ghc_timing True) )
2281
2282         ------ Debugging ----------------------------------------------------
2283   ,  ( "dstg-stats"        , NoArg (writeIORef opt_StgStats True) )
2284
2285   ,  ( "dno-"              , Prefix (\s -> addAntiOpt_C ("-d"++s)) )
2286   ,  ( "d"                 , AnySuffix (addOpt_C) )
2287
2288         ------ Machine dependant (-m<blah>) stuff ---------------------------
2289
2290   ,  ( "monly-2-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
2291   ,  ( "monly-3-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 3}) ))
2292   ,  ( "monly-4-regs",          NoArg (updateState (\s -> s{stolen_x86_regs = 4}) ))
2293
2294         ------ Compiler flags -----------------------------------------------
2295   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
2296   ,  ( "O"                 , OptPrefix (setOptLevel) )
2297
2298   ,  ( "fglasgow-exts-no-lang", NoArg ( do addOpt_C "-fglasgow-exts") )
2299
2300   ,  ( "fglasgow-exts"     , NoArg (do addOpt_C "-fglasgow-exts"
2301                                        addPackage "lang"))
2302
2303   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
2304
2305   ,  ( "fvia-c"            , NoArg (writeIORef hsc_lang HscC) )
2306   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
2307
2308   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling False) )
2309
2310   ,  ( "fmax-simplifier-iterations",
2311                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
2312
2313   ,  ( "fusagesp"          , NoArg (do writeIORef opt_UsageSPInf True
2314                                        addOpt_C "-fusagesp-on") )
2315
2316   ,  ( "fexcess-precision" , NoArg (do updateState
2317                                            (\s -> s{ excess_precision = True })
2318                                        addOpt_C "-fexcess-precision"))
2319
2320         -- flags that are "active negatives"
2321   ,  ( "fno-implicit-prelude"   , PassFlag (addOpt_C) )
2322   ,  ( "fno-prune-tydecls"      , PassFlag (addOpt_C) )
2323   ,  ( "fno-prune-instdecls"    , PassFlag (addOpt_C) )
2324   ,  ( "fno-pre-inlining"       , PassFlag (addOpt_C) )
2325
2326         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
2327   ,  ( "fno-",                  Prefix (\s -> addAntiOpt_C ("-f"++s)) )
2328
2329         -- Pass all remaining "-f<blah>" options to hsc
2330   ,  ( "f",                     AnySuffix (addOpt_C) )
2331   ]
2332
2333 -----------------------------------------------------------------------------
2334 -- Process command-line
2335
2336 processArgs :: [(String,OptKind)] -> [String] -> [String]
2337    -> IO [String]  -- returns spare args
2338 processArgs _spec [] spare = return (reverse spare)
2339 processArgs spec args@(('-':_):_) spare = do
2340   args' <- processOneArg spec args
2341   processArgs spec args' spare
2342 processArgs spec (arg:args) spare =
2343   processArgs spec args (arg:spare)
2344
2345 processOneArg :: [(String,OptKind)] -> [String] -> IO [String]
2346 processOneArg spec (('-':arg):args) = do
2347   let (rest,action) = findArg spec arg
2348       dash_arg = '-':arg
2349   case action of
2350
2351         NoArg  io ->
2352                 if rest == ""
2353                         then io >> return args
2354                         else unknownFlagErr dash_arg
2355
2356         HasArg fio ->
2357                 if rest /= ""
2358                         then fio rest >> return args
2359                         else case args of
2360                                 [] -> unknownFlagErr dash_arg
2361                                 (arg1:args1) -> fio arg1 >> return args1
2362
2363         SepArg fio ->
2364                 case args of
2365                         [] -> unknownFlagErr dash_arg
2366                         (arg1:args1) -> fio arg1 >> return args1
2367
2368         Prefix fio ->
2369                 if rest /= ""
2370                         then fio rest >> return args
2371                         else unknownFlagErr dash_arg
2372
2373         OptPrefix fio -> fio rest >> return args
2374
2375         AnySuffix fio -> fio ('-':arg) >> return args
2376
2377         PassFlag fio  ->
2378                 if rest /= ""
2379                         then unknownFlagErr dash_arg
2380                         else fio ('-':arg) >> return args
2381
2382 findArg :: [(String,OptKind)] -> String -> (String,OptKind)
2383 findArg spec arg
2384   = case [ (remove_spaces rest, k) | (pat,k) <- spec,
2385                                      Just rest <- [my_prefix_match pat arg],
2386                                      is_prefix k || null rest ] of
2387         [] -> unknownFlagErr ('-':arg)
2388         (one:_) -> one
2389
2390 is_prefix (NoArg _) = False
2391 is_prefix (SepArg _) = False
2392 is_prefix (PassFlag _) = False
2393 is_prefix _ = True
2394
2395 -----------------------------------------------------------------------------
2396 -- convert sizes like "3.5M" into integers
2397
2398 decodeSize :: String -> Integer
2399 decodeSize str
2400   | c == ""              = truncate n
2401   | c == "K" || c == "k" = truncate (n * 1000)
2402   | c == "M" || c == "m" = truncate (n * 1000 * 1000)
2403   | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)
2404   | otherwise            = throwDyn (OtherError ("can't decode size: " ++ str))
2405   where (m, c) = span pred str
2406         n      = read m  :: Double
2407         pred c = isDigit c || c == '.'
2408
2409 floatOpt :: IORef Double -> String -> IO ()
2410 floatOpt ref str
2411   = writeIORef ref (read str :: Double)
2412
2413 -----------------------------------------------------------------------------
2414 -- Finding files in the installation
2415
2416 GLOBAL_VAR(topDir, clibdir, String)
2417
2418         -- grab the last -B option on the command line, and
2419         -- set topDir to its value.
2420 setTopDir :: [String] -> IO [String]
2421 setTopDir args = do
2422   let (minusbs, others) = partition (prefixMatch "-B") args
2423   (case minusbs of
2424     []   -> writeIORef topDir clibdir
2425     some -> writeIORef topDir (drop 2 (last some)))
2426   return others
2427
2428 findFile name alt_path = unsafePerformIO (do
2429   top_dir <- readIORef topDir
2430   let installed_file = top_dir ++ '/':name
2431   let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
2432   b <- doesFileExist inplace_file
2433   if b  then return inplace_file
2434         else return installed_file
2435  )
2436
2437 -----------------------------------------------------------------------------
2438 -- Utils
2439
2440 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
2441 my_partition _ [] = ([],[])
2442 my_partition p (a:as)
2443   = let (bs,cs) = my_partition p as in
2444     case p a of
2445         Nothing -> (bs,a:cs)
2446         Just b  -> ((a,b):bs,cs)
2447
2448 my_prefix_match :: String -> String -> Maybe String
2449 my_prefix_match [] rest = Just rest
2450 my_prefix_match (_:_) [] = Nothing
2451 my_prefix_match (p:pat) (r:rest)
2452   | p == r    = my_prefix_match pat rest
2453   | otherwise = Nothing
2454
2455 later = flip finally
2456
2457 my_catchDyn = flip catchDyn
2458
2459 global :: a -> IORef a
2460 global a = unsafePerformIO (newIORef a)
2461
2462 splitFilename :: String -> (String,String)
2463 splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
2464   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
2465         stripDot ('.':xs) = xs
2466         stripDot xs       = xs
2467
2468 suffixOf :: String -> String
2469 suffixOf s = drop_longest_prefix s '.'
2470
2471 split :: Char -> String -> [String]
2472 split c s = case rest of
2473                 []     -> [chunk]
2474                 _:rest -> chunk : split c rest
2475   where (chunk, rest) = break (==c) s
2476
2477 add :: IORef [a] -> a -> IO ()
2478 add var x = do
2479   xs <- readIORef var
2480   writeIORef var (x:xs)
2481
2482 addNoDups :: Eq a => IORef [a] -> a -> IO ()
2483 addNoDups var x = do
2484   xs <- readIORef var
2485   unless (x `elem` xs) $ writeIORef var (x:xs)
2486
2487 remove_suffix :: Char -> String -> String
2488 remove_suffix c s
2489   | null pre  = reverse suf
2490   | otherwise = reverse pre
2491   where (suf,pre) = break (==c) (reverse s)
2492
2493 drop_longest_prefix :: String -> Char -> String
2494 drop_longest_prefix s c = reverse suf
2495   where (suf,_pre) = break (==c) (reverse s)
2496
2497 take_longest_prefix :: String -> Char -> String
2498 take_longest_prefix s c = reverse pre
2499   where (_suf,pre) = break (==c) (reverse s)
2500
2501 newsuf :: String -> String -> String
2502 newsuf suf s = remove_suffix '.' s ++ suf
2503
2504 -- getdir strips the filename off the input string, returning the directory.
2505 getdir :: String -> String
2506 getdir s = if null dir then "." else init dir
2507   where dir = take_longest_prefix s '/'
2508
2509 newdir :: String -> String -> String
2510 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
2511
2512 remove_spaces :: String -> String
2513 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
2514
2515 -----------------------------------------------------------------------------
2516 -- compatibility code
2517
2518 #if __GLASGOW_HASKELL__ <= 408
2519 catchJust = catchIO
2520 ioErrors  = justIoErrors
2521 #endif