ghc/driver/Main.hs

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