ghc/driver/Main.hs

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