ghc/driver/Main.hs

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