ghc/driver/Main.hs

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