ghc/driver/Main.hs

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