ghc/driver/Main.hs

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