ghc/driver/Main.hs

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