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   unless forget_it $ 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   unless access $
 593         throwDyn (OtherError "you don't have permission to modify the package configuration file")
 594
 595 maybeRestoreOldConfig :: String -> IO () -> IO ()
 596 maybeRestoreOldConfig conf_file io
 597   = catchAllIO io (\e -> do
 598         hPutStr stdout "\nWARNING: an error was encountered while the new \n\
 599                        \configuration was being written.  Attempting to \n\
 600                        \restore the old configuration... "
 601         system ("cp " ++ conf_file ++ ".old " ++ conf_file)
 602         hPutStrLn stdout "done."
 603         throw e
 604     )
 605
 606 writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
 607 writeNewConfig conf_file fn = do
 608   hPutStr stdout "Writing new package config file... "
 609   old_details <- readIORef package_details
 610   h <- openFile conf_file WriteMode
 611   hPutStr h (dumpPackages (fn old_details))
 612   hClose h
 613   hPutStrLn stdout "done."
 614
 615 savePackageConfig :: String -> IO ()
 616 savePackageConfig conf_file = do
 617   hPutStr stdout "Saving old package config file... "
 618     -- mv rather than cp because we've already done an hGetContents
 619     -- on this file so we won't be able to open it for writing
 620     -- unless we move the old one out of the way...
 621   system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
 622   hPutStrLn stdout "done."
 623
 624 -- package list is maintained in dependency order
 625 packages = global ["std", "rts", "gmp"] :: IORef [String]
 626 -- comma in value, so can't use macro, grrr
 627 {-# NOINLINE packages #-}
 628
 629 addPackage :: String -> IO ()
 630 addPackage package
 631   = do pkg_details <- readIORef package_details
 632        case lookup package pkg_details of
 633           Nothing -> throwDyn (UnknownPackage package)
 634           Just details -> do
 635             ps <- readIORef packages
 636             unless (package `elem` ps) $ do
 637                 mapM_ addPackage (package_deps details)
 638                 ps <- readIORef packages
 639                 writeIORef packages (package:ps)
 640
 641 getPackageImportPath   :: IO [String]
 642 getPackageImportPath = do
 643   ps <- readIORef packages
 644   ps' <- getPackageDetails ps
 645   return (nub (concat (map import_dirs ps')))
 646
 647 getPackageIncludePath   :: IO [String]
 648 getPackageIncludePath = do
 649   ps <- readIORef packages
 650   ps' <- getPackageDetails ps
 651   return (nub (filter (not.null) (concatMap include_dirs ps')))
 652
 653         -- includes are in reverse dependency order (i.e. rts first)
 654 getPackageCIncludes   :: IO [String]
 655 getPackageCIncludes = do
 656   ps <- readIORef packages
 657   ps' <- getPackageDetails ps
 658   return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
 659
 660 getPackageLibraryPath  :: IO [String]
 661 getPackageLibraryPath = do
 662   ps <- readIORef packages
 663   ps' <- getPackageDetails ps
 664   return (nub (concat (map library_dirs ps')))
 665
 666 getPackageLibraries    :: IO [String]
 667 getPackageLibraries = do
 668   ps <- readIORef packages
 669   ps' <- getPackageDetails ps
 670   tag <- readIORef build_tag
 671   let suffix = if null tag then "" else '_':tag
 672   return (concat (map libraries ps'))
 673
 674 getPackageExtraGhcOpts :: IO [String]
 675 getPackageExtraGhcOpts = do
 676   ps <- readIORef packages
 677   ps' <- getPackageDetails ps
 678   return (concatMap extra_ghc_opts ps')
 679
 680 getPackageExtraCcOpts  :: IO [String]
 681 getPackageExtraCcOpts = do
 682   ps <- readIORef packages
 683   ps' <- getPackageDetails ps
 684   return (concatMap extra_cc_opts ps')
 685
 686 getPackageExtraLdOpts  :: IO [String]
 687 getPackageExtraLdOpts = do
 688   ps <- readIORef packages
 689   ps' <- getPackageDetails ps
 690   return (concatMap extra_ld_opts ps')
 691
 692 getPackageDetails :: [String] -> IO [Package]
 693 getPackageDetails ps = do
 694   pkg_details <- readIORef package_details
 695   return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ]
 696
 697 GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
 698
 699 -----------------------------------------------------------------------------
 700 -- Ways
 701
 702 -- The central concept of a "way" is that all objects in a given
 703 -- program must be compiled in the same "way".  Certain options change
 704 -- parameters of the virtual machine, eg. profiling adds an extra word
 705 -- to the object header, so profiling objects cannot be linked with
 706 -- non-profiling objects.
 707
 708 -- After parsing the command-line options, we determine which "way" we
 709 -- are building - this might be a combination way, eg. profiling+ticky-ticky.
 710
 711 -- We then find the "build-tag" associated with this way, and this
 712 -- becomes the suffix used to find .hi files and libraries used in
 713 -- this compilation.
 714
 715 GLOBAL_VAR(build_tag, "", String)
 716
 717 data WayName
 718   = WayProf
 719   | WayUnreg
 720   | WayTicky
 721   | WayPar
 722   | WayGran
 723   | WaySMP
 724   | WayDebug
 725   | WayUser_a
 726   | WayUser_b
 727   | WayUser_c
 728   | WayUser_d
 729   | WayUser_e
 730   | WayUser_f
 731   | WayUser_g
 732   | WayUser_h
 733   | WayUser_i
 734   | WayUser_j
 735   | WayUser_k
 736   | WayUser_l
 737   | WayUser_m
 738   | WayUser_n
 739   | WayUser_o
 740   | WayUser_A
 741   | WayUser_B
 742   deriving (Eq,Ord)
 743
 744 GLOBAL_VAR(ways, [] ,[WayName])
 745
 746 allowed_combinations =
 747    [  [WayProf,WayUnreg],
 748       [WayProf,WaySMP]     -- works???
 749    ]
 750
 751 findBuildTag :: IO [String]  -- new options
 752 findBuildTag = do
 753   way_names <- readIORef ways
 754   case sort way_names of
 755      []  -> do  writeIORef build_tag ""
 756                 return []
 757
 758      [w] -> do let details = lkupWay w
 759                writeIORef build_tag (wayTag details)
 760                return (wayOpts details)
 761
 762      ws  -> if  ws `notElem` allowed_combinations
 763                 then throwDyn (WayCombinationNotSupported ws)
 764                 else let stuff = map lkupWay ws
 765                          tag   = concat (map wayTag stuff)
 766                          flags = map wayOpts stuff
 767                      in do
 768                      writeIORef build_tag tag
 769                      return (concat flags)
 770
 771 lkupWay w =
 772    case lookup w way_details of
 773         Nothing -> error "findBuildTag"
 774         Just details -> details
 775
 776 data Way = Way {
 777   wayTag   :: String,
 778   wayName  :: String,
 779   wayOpts  :: [String]
 780   }
 781
 782 way_details :: [ (WayName, Way) ]
 783 way_details =
 784   [ (WayProf, Way  "p" "Profiling"
 785         [ "-fscc-profiling"
 786         , "-DPROFILING"
 787         , "-optc-DPROFILING" ]),
 788
 789     (WayTicky, Way  "t" "Ticky-ticky Profiling"
 790         [ "-fticky-ticky"
 791         , "-DTICKY_TICKY"
 792         , "-optc-DTICKY_TICKY" ]),
 793
 794     (WayUnreg, Way  "u" "Unregisterised"
 795         [ "-optc-DNO_REGS"
 796         , "-optc-DUSE_MINIINTERPRETER"
 797         , "-fno-asm-mangling"
 798         , "-funregisterised" ]),
 799
 800     (WayPar, Way  "mp" "Parallel"
 801         [ "-fstack-check"
 802         , "-fparallel"
 803         , "-D__PARALLEL_HASKELL__"
 804         , "-optc-DPAR"
 805         , "-package concurrent" ]),
 806
 807     (WayGran, Way  "mg" "Gransim"
 808         [ "-fstack-check"
 809         , "-fgransim"
 810         , "-D__GRANSIM__"
 811         , "-optc-DGRAN"
 812         , "-package concurrent" ]),
 813
 814     (WaySMP, Way  "s" "SMP"
 815         [ "-fsmp"
 816         , "-optc-pthread"
 817         , "-optl-pthread"
 818         , "-optc-DSMP" ]),
 819
 820     (WayUser_a,  Way  "a"  "User way 'a'"  ["$WAY_a_REAL_OPTS"]),
 821     (WayUser_b,  Way  "b"  "User way 'b'"  ["$WAY_b_REAL_OPTS"]),
 822     (WayUser_c,  Way  "c"  "User way 'c'"  ["$WAY_c_REAL_OPTS"]),
 823     (WayUser_d,  Way  "d"  "User way 'd'"  ["$WAY_d_REAL_OPTS"]),
 824     (WayUser_e,  Way  "e"  "User way 'e'"  ["$WAY_e_REAL_OPTS"]),
 825     (WayUser_f,  Way  "f"  "User way 'f'"  ["$WAY_f_REAL_OPTS"]),
 826     (WayUser_g,  Way  "g"  "User way 'g'"  ["$WAY_g_REAL_OPTS"]),
 827     (WayUser_h,  Way  "h"  "User way 'h'"  ["$WAY_h_REAL_OPTS"]),
 828     (WayUser_i,  Way  "i"  "User way 'i'"  ["$WAY_i_REAL_OPTS"]),
 829     (WayUser_j,  Way  "j"  "User way 'j'"  ["$WAY_j_REAL_OPTS"]),
 830     (WayUser_k,  Way  "k"  "User way 'k'"  ["$WAY_k_REAL_OPTS"]),
 831     (WayUser_l,  Way  "l"  "User way 'l'"  ["$WAY_l_REAL_OPTS"]),
 832     (WayUser_m,  Way  "m"  "User way 'm'"  ["$WAY_m_REAL_OPTS"]),
 833     (WayUser_n,  Way  "n"  "User way 'n'"  ["$WAY_n_REAL_OPTS"]),
 834     (WayUser_o,  Way  "o"  "User way 'o'"  ["$WAY_o_REAL_OPTS"]),
 835     (WayUser_A,  Way  "A"  "User way 'A'"  ["$WAY_A_REAL_OPTS"]),
 836     (WayUser_B,  Way  "B"  "User way 'B'"  ["$WAY_B_REAL_OPTS"])
 837   ]
 838
 839 -----------------------------------------------------------------------------
 840 -- Programs for particular phases
 841
 842 GLOBAL_VAR(pgm_dep, findFile "mkdependHS" cGHC_MKDEPENDHS, String)
 843 GLOBAL_VAR(pgm_L,   findFile "unlit"      cGHC_UNLIT,      String)
 844 GLOBAL_VAR(pgm_P,   cRAWCPP,                               String)
 845 GLOBAL_VAR(pgm_C,   findFile "hsc"        cGHC_HSC,        String)
 846 GLOBAL_VAR(pgm_c,   cGCC,                                  String)
 847 GLOBAL_VAR(pgm_m,   findFile "ghc-asm"    cGHC_MANGLER,    String)
 848 GLOBAL_VAR(pgm_s,   findFile "ghc-split"  cGHC_SPLIT,      String)
 849 GLOBAL_VAR(pgm_a,   cGCC,                                  String)
 850 GLOBAL_VAR(pgm_l,   cGCC,                                  String)
 851
 852 -----------------------------------------------------------------------------
 853 -- Options for particular phases
 854
 855 GLOBAL_VAR(opt_dep, [], [String])
 856 GLOBAL_VAR(opt_L, [], [String])
 857 GLOBAL_VAR(opt_P, [], [String])
 858 GLOBAL_VAR(opt_C, [], [String])
 859 GLOBAL_VAR(opt_Crts, [], [String])
 860 GLOBAL_VAR(opt_c, [], [String])
 861 GLOBAL_VAR(opt_a, [], [String])
 862 GLOBAL_VAR(opt_m, [], [String])
 863 GLOBAL_VAR(opt_l, [], [String])
 864 GLOBAL_VAR(opt_dll, [], [String])
 865
 866         -- we add to the options from the front, so we need to reverse the list
 867 getOpts :: IORef [String] -> IO [String]
 868 getOpts opts = readIORef opts >>= return . reverse
 869
 870 GLOBAL_VAR(anti_opt_C, [], [String])
 871
 872 -----------------------------------------------------------------------------
 873 -- Via-C compilation stuff
 874
 875 -- flags returned are: ( all C compilations
 876 --                     , registerised HC compilations
 877 --                     )
 878
 879 machdepCCOpts
 880    | prefixMatch "alpha"   cTARGETPLATFORM
 881         = return ( ["-static"], [] )
 882
 883    | prefixMatch "hppa"    cTARGETPLATFORM
 884         -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
 885         -- (very nice, but too bad the HP /usr/include files don't agree.)
 886         = return ( ["-static", "-D_HPUX_SOURCE"], [] )
 887
 888    | prefixMatch "m68k"    cTARGETPLATFORM
 889       -- -fno-defer-pop : for the .hc files, we want all the pushing/
 890       --    popping of args to routines to be explicit; if we let things
 891       --    be deferred 'til after an STGJUMP, imminent death is certain!
 892       --
 893       -- -fomit-frame-pointer : *don't*
 894       --     It's better to have a6 completely tied up being a frame pointer
 895       --     rather than let GCC pick random things to do with it.
 896       --     (If we want to steal a6, then we would try to do things
 897       --     as on iX86, where we *do* steal the frame pointer [%ebp].)
 898         = return ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
 899
 900    | prefixMatch "i386"    cTARGETPLATFORM
 901       -- -fno-defer-pop : basically the same game as for m68k
 902       --
 903       -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
 904       --   the fp (%ebp) for our register maps.
 905         = do n_regs <- readIORef stolen_x86_regs
 906              sta    <- readIORef static
 907              return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" ],
 908                       [ "-fno-defer-pop", "-fomit-frame-pointer",
 909                         "-DSTOLEN_X86_REGS="++show n_regs ]
 910                     )
 911
 912    | prefixMatch "mips"    cTARGETPLATFORM
 913         = return ( ["static"], [] )
 914
 915    | prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
 916         = return ( ["static"], ["-finhibit-size-directive"] )
 917
 918    | otherwise
 919         = return ( [], [] )
 920
 921 -----------------------------------------------------------------------------
 922 -- Build the Hsc command line
 923
 924 build_hsc_opts :: IO [String]
 925 build_hsc_opts = do
 926   opt_C_ <- getOpts opt_C               -- misc hsc opts
 927
 928         -- warnings
 929   warn_level <- readIORef warning_opt
 930   let warn_opts =  case warn_level of
 931                         W_default -> standardWarnings
 932                         W_        -> minusWOpts
 933                         W_all     -> minusWallOpts
 934                         W_not     -> []
 935
 936         -- optimisation
 937   minus_o <- readIORef opt_level
 938   optimisation_opts <-
 939         case minus_o of
 940             0 -> hsc_minusNoO_flags
 941             1 -> hsc_minusO_flags
 942             2 -> hsc_minusO2_flags
 943             -- ToDo: -Ofile
 944
 945         -- STG passes
 946   ways_ <- readIORef ways
 947   let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
 948                   | otherwise            = ""
 949
 950   stg_stats <- readIORef opt_StgStats
 951   let stg_stats_flag | stg_stats = "-dstg-stats"
 952                      | otherwise = ""
 953
 954   let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
 955         -- let-no-escape always on for now
 956
 957   verb <- is_verbose
 958   let hi_vers = "-fhi-version="++cProjectVersionInt
 959   static <- (do s <- readIORef static; if s then return "-static" else return "")
 960
 961   l <- readIORef hsc_lang
 962   let lang = case l of
 963                 HscC    -> "-olang=C"
 964                 HscAsm  -> "-olang=asm"
 965                 HscJava -> "-olang=java"
 966
 967   -- get hi-file suffix
 968   hisuf <- readIORef hi_suf
 969
 970   -- hi-suffix for packages depends on the build tag.
 971   package_hisuf <-
 972         do tag <- readIORef build_tag
 973            if null tag
 974                 then return "hi"
 975                 else return (tag ++ "_hi")
 976
 977   import_dirs <- readIORef import_paths
 978   package_import_dirs <- getPackageImportPath
 979
 980   let hi_map = "-himap=" ++
 981                 makeHiMap import_dirs hisuf
 982                          package_import_dirs package_hisuf
 983                          split_marker
 984
 985       hi_map_sep = "-himap-sep=" ++ [split_marker]
 986
 987   scale <- readIORef scale_sizes_by
 988   heap  <- readIORef specific_heap_size
 989   stack <- readIORef specific_stack_size
 990   cmdline_rts_opts <- getOpts opt_Crts
 991   let heap'  = truncate (fromIntegral heap  * scale) :: Integer
 992       stack' = truncate (fromIntegral stack * scale) :: Integer
 993       rts_opts = [ "+RTS", "-H"++show heap', "-K"++show stack' ]
 994                  ++ cmdline_rts_opts ++ [ "-RTS" ]
 995
 996   -- take into account -fno-* flags by removing the equivalent -f*
 997   -- flag from our list.
 998   anti_flags <- getOpts anti_opt_C
 999   let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
1000       filtered_opts = filter (`notElem` anti_flags) basic_opts
1001
1002   return
1003         (
1004         filtered_opts
1005         -- ToDo: C stub files
1006         ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
1007         ++ rts_opts
1008         )
1009
1010 makeHiMap
1011   (import_dirs         :: [String])
1012   (hi_suffix           :: String)
1013   (package_import_dirs :: [String])
1014   (package_hi_suffix   :: String)
1015   (split_marker        :: Char)
1016   = foldr (add_dir hi_suffix)
1017         (foldr (add_dir package_hi_suffix) "" package_import_dirs)
1018         import_dirs
1019   where
1020      add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
1021
1022
1023 getOptionsFromSource
1024         :: String               -- input file
1025         -> IO [String]          -- options, if any
1026 getOptionsFromSource file
1027   = do h <- openFile file ReadMode
1028        look h
1029   where
1030         look h = do
1031             l <- hGetLine h
1032             case () of
1033                 () | null l -> look h
1034                    | prefixMatch "#" l -> look h
1035                    | prefixMatch "{-# LINE" l -> look h
1036                    | Just (opts:_) <- matchRegex optionRegex l
1037                         -> return (words opts)
1038                    | otherwise -> return []
1039
1040 optionRegex = mkRegex "{-#[ \t]+OPTIONS[ \t]+(.*)#-}"
1041
1042 -----------------------------------------------------------------------------
1043 -- Main loop
1044
1045 get_source_files :: [String] -> ([String],[String])
1046 get_source_files = partition (('-' /=) . head)
1047
1048 suffixes :: [(String,Phase)]
1049 suffixes =
1050   [ ("lhs",   Unlit)
1051   , ("hs",    Cpp)
1052   , ("hc",    HCc)
1053   , ("c",     Cc)
1054   , ("raw_s", Mangle)
1055   , ("s",     As)
1056   , ("S",     As)
1057   , ("o",     Ln)
1058   ]
1059
1060 phase_input_ext Unlit       = "lhs"
1061 phase_input_ext Cpp         = "lpp"
1062 phase_input_ext Hsc         = "cpp"
1063 phase_input_ext HCc         = "hc"
1064 phase_input_ext Cc          = "c"
1065 phase_input_ext Mangle      = "raw_s"
1066 phase_input_ext SplitMangle = "split_s" -- not really generated
1067 phase_input_ext As          = "s"
1068 phase_input_ext SplitAs     = "split_s" -- not really generated
1069 phase_input_ext Ln          = "o"
1070
1071 find_phase :: String -> ([(Phase,String)], [String])
1072    -> ([(Phase,String)], [String])
1073 find_phase f (phase_srcs, unknown_srcs)
1074   = case lookup ext suffixes of
1075         Just the_phase -> ((the_phase,f):phase_srcs, unknown_srcs)
1076         Nothing        -> (phase_srcs, f:unknown_srcs)
1077   where (basename,ext) = split_filename f
1078
1079
1080 find_phases srcs = (phase_srcs, unknown_srcs)
1081   where (phase_srcs, unknown_srcs) = foldr find_phase ([],[]) srcs
1082
1083 main =
1084   -- all error messages are propagated as exceptions
1085   my_catchDyn (\dyn -> case dyn of
1086                           PhaseFailed phase code -> exitWith code
1087                           Interrupted -> exitWith (ExitFailure 1)
1088                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
1089                                   exitWith (ExitFailure 1)) $
1090
1091   later cleanTempFiles $
1092         -- exceptions will be blocked while we clean the temporary files,
1093         -- so there shouldn't be any difficulty if we receive further
1094         -- signals.
1095
1096   do
1097         -- install signal handlers
1098    main_thread <- myThreadId
1099    let sig_handler = Catch (raiseInThread main_thread
1100                                 (DynException (toDyn Interrupted)))
1101    installHandler sigQUIT sig_handler Nothing
1102    installHandler sigINT  sig_handler Nothing
1103
1104    pgm    <- getProgName
1105    writeIORef prog_name pgm
1106
1107    argv   <- getArgs
1108
1109    -- grab any -B options from the command line first
1110    argv'  <- setTopDir argv
1111
1112    -- read the package configuration
1113    conf_file <- readIORef package_config
1114    contents <- readFile conf_file
1115    writeIORef package_details (read contents)
1116
1117    -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
1118    (flags2, stop_phase, do_linking) <- getStopAfter argv'
1119
1120    -- process all the other arguments, and get the source files
1121    srcs   <- processArgs flags2 []
1122
1123    -- find the build tag, and re-process the build-specific options
1124    more_opts <- findBuildTag
1125    _ <- processArgs more_opts []
1126
1127    -- get the -v flag
1128    verb <- readIORef verbose
1129
1130    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
1131
1132    if stop_phase == MkDependHS          -- mkdependHS is special
1133         then do_mkdependHS flags2 srcs
1134         else do
1135
1136    -- for each source file, find which phase to start at
1137    let (phase_srcs, unknown_srcs) = find_phases srcs
1138
1139    o_file <- readIORef output_file
1140    if isJust o_file && not do_linking && length phase_srcs > 1
1141         then throwDyn MultipleSrcsOneOutput
1142         else do
1143
1144    if null unknown_srcs && null phase_srcs
1145         then throwDyn NoInputFiles
1146         else do
1147
1148    -- if we have unknown files, and we're not doing linking, complain
1149    -- (otherwise pass them through to the linker).
1150    if not (null unknown_srcs) && not do_linking
1151         then throwDyn (UnknownFileType (head unknown_srcs))
1152         else do
1153
1154    let  compileFile :: (Phase, String) -> IO String
1155         compileFile (phase, src) = do
1156           let (orig_base, _) = split_filename src
1157           if phase < Ln -- anything to do?
1158                 then run_pipeline stop_phase do_linking True orig_base (phase,src)
1159                 else return src
1160
1161    o_files <- mapM compileFile phase_srcs
1162
1163    when do_linking $
1164         do_link o_files unknown_srcs
1165
1166
1167 -- The following compilation pipeline algorithm is fairly hacky.  A
1168 -- better way to do this would be to express the whole comilation as a
1169 -- data flow DAG, where the nodes are the intermediate files and the
1170 -- edges are the compilation phases.  This framework would also work
1171 -- nicely if a haskell dependency generator was included in the
1172 -- driver.
1173
1174 -- It would also deal much more cleanly with compilation phases that
1175 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
1176 -- possibly stub files), where some of the output files need to be
1177 -- processed further (eg. the stub files need to be compiled by the C
1178 -- compiler).
1179
1180 -- A cool thing to do would then be to execute the data flow graph
1181 -- concurrently, automatically taking advantage of extra processors on
1182 -- the host machine.  For example, when compiling two Haskell files
1183 -- where one depends on the other, the data flow graph would determine
1184 -- that the C compiler from the first comilation can be overlapped
1185 -- with the hsc comilation for the second file.
1186
1187 run_pipeline
1188   :: Phase              -- phase to end on (never Linker)
1189   -> Bool               -- doing linking afterward?
1190   -> Bool               -- take into account -o when generating output?
1191   -> String             -- original basename (eg. Main)
1192   -> (Phase, String)    -- phase to run, input file
1193   -> IO String          -- return final filename
1194
1195 run_pipeline last_phase do_linking use_ofile orig_basename (phase, input_fn)
1196   | phase > last_phase = return input_fn
1197   | otherwise
1198   = do
1199
1200      let (basename,ext) = split_filename input_fn
1201
1202      split  <- readIORef split_object_files
1203      mangle <- readIORef do_asm_mangling
1204      lang   <- readIORef hsc_lang
1205
1206         -- figure out what the next phase is.  This is
1207         -- straightforward, apart from the fact that hsc can generate
1208         -- either C or assembler direct, and assembly mangling is
1209         -- optional, and splitting involves one extra phase and an alternate
1210         -- assembler.
1211      let next_phase =
1212           case phase of
1213                 Hsc -> case lang of
1214                             HscC   -> HCc
1215                             HscAsm | split     -> SplitMangle
1216                                    | otherwise -> As
1217
1218                 HCc  | mangle    -> Mangle
1219                      | otherwise -> As
1220
1221                 Cc -> As
1222
1223                 Mangle | not split -> As
1224                 SplitMangle -> SplitAs
1225                 SplitAs -> Ln
1226
1227                 _  -> succ phase
1228
1229
1230         -- filename extension for the output, determined by next_phase
1231      let new_ext = phase_input_ext next_phase
1232
1233         -- Figure out what the output from this pass should be called.
1234
1235         -- If we're keeping the output from this phase, then we just save
1236         -- it in the current directory, otherwise we generate a new temp file.
1237      keep_s <- readIORef keep_s_files
1238      keep_raw_s <- readIORef keep_raw_s_files
1239      keep_hc <- readIORef keep_hc_files
1240      let keep_this_output =
1241            case next_phase of
1242                 Ln -> True
1243                 Mangle | keep_raw_s -> True -- first enhancement :)
1244                 As | keep_s  -> True
1245                 HCc | keep_hc -> True
1246                 _other -> False
1247
1248      output_fn <-
1249         (if next_phase > last_phase && not do_linking && use_ofile
1250             then do o_file <- readIORef output_file
1251                     case o_file of
1252                         Just s  -> return s
1253                         Nothing -> do
1254                             f <- odir_ify (orig_basename ++ '.':new_ext)
1255                             osuf_ify f
1256
1257                 -- .o files are always kept.  .s files and .hc file may be kept.
1258             else if keep_this_output
1259                         then odir_ify (orig_basename ++ '.':new_ext)
1260                         else do filename <- newTempName new_ext
1261                                 add files_to_clean filename
1262                                 return filename
1263         )
1264
1265      run_phase phase orig_basename input_fn output_fn
1266
1267         -- sadly, ghc -E is supposed to write the file to stdout.  We
1268         -- generate <file>.cpp, so we also have to cat the file here.
1269      when (next_phase > last_phase && last_phase == Cpp) $
1270         run_something "Dump pre-processed file to stdout"
1271                       ("cat " ++ output_fn)
1272
1273      run_pipeline last_phase do_linking use_ofile
1274           orig_basename (next_phase, output_fn)
1275
1276
1277 -- find a temporary name that doesn't already exist.
1278 newTempName :: String -> IO String
1279 newTempName extn = do
1280   x <- getProcessID
1281   tmp_dir <- readIORef tmp_prefix
1282   findTempName tmp_dir x
1283   where findTempName tmp_dir x = do
1284            let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
1285            b  <- fileExist filename
1286            if b then findTempName tmp_dir (x+1)
1287                 else return filename
1288
1289 -------------------------------------------------------------------------------
1290 -- mkdependHS phase
1291
1292 do_mkdependHS :: [String] -> [String] -> IO ()
1293 do_mkdependHS cmd_opts srcs = do
1294    -- HACK
1295    let quote_include_opt o | prefixMatch "-#include" o = "'" ++ o ++ "'"
1296                            | otherwise                 = o
1297
1298    mkdependHS      <- readIORef pgm_dep
1299    mkdependHS_opts <- getOpts opt_dep
1300    hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1301
1302    run_something "Dependency generation"
1303         (unwords (mkdependHS :
1304                       mkdependHS_opts
1305                    ++ hs_src_cpp_opts
1306                    ++ ("--" : map quote_include_opt cmd_opts )
1307                    ++ ("--" : srcs)
1308         ))
1309
1310 -------------------------------------------------------------------------------
1311 -- Unlit phase
1312
1313 run_phase Unlit basename input_fn output_fn
1314   = do unlit <- readIORef pgm_L
1315        unlit_flags <- getOpts opt_L
1316        run_something "Literate pre-processor"
1317           ("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
1318            ++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
1319
1320 -------------------------------------------------------------------------------
1321 -- Cpp phase
1322
1323 run_phase Cpp basename input_fn output_fn
1324   = do src_opts <- getOptionsFromSource input_fn
1325        processArgs src_opts []
1326
1327        do_cpp <- readIORef cpp_flag
1328        if do_cpp
1329           then do
1330             cpp <- readIORef pgm_P
1331             hscpp_opts <- getOpts opt_P
1332             hs_src_cpp_opts <- readIORef hs_source_cpp_opts
1333
1334             cmdline_include_paths <- readIORef include_paths
1335             pkg_include_dirs <- getPackageIncludePath
1336             let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
1337                                                         ++ pkg_include_dirs)
1338
1339             verb <- is_verbose
1340             run_something "C pre-processor"
1341                 (unwords
1342                    (["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
1343                      cpp, verb]
1344                     ++ include_paths
1345                     ++ hs_src_cpp_opts
1346                     ++ hscpp_opts
1347                     ++ [ "-x", "c", input_fn, ">>", output_fn ]
1348                    ))
1349           else do
1350             run_something "Inefective C pre-processor"
1351                    ("echo '{-# LINE 1 \""  ++ input_fn ++ "\" -}' > "
1352                     ++ output_fn ++ " && cat " ++ input_fn
1353                     ++ " >> " ++ output_fn)
1354
1355 -----------------------------------------------------------------------------
1356 -- Hsc phase
1357
1358 run_phase Hsc   basename input_fn output_fn
1359   = do  hsc <- readIORef pgm_C
1360
1361   -- we add the current directory (i.e. the directory in which
1362   -- the .hs files resides) to the import path, since this is
1363   -- what gcc does, and it's probably what you want.
1364         let current_dir = getdir basename
1365
1366         paths <- readIORef include_paths
1367         writeIORef include_paths (current_dir : paths)
1368
1369   -- build the hsc command line
1370         hsc_opts <- build_hsc_opts
1371
1372         doing_hi <- readIORef produceHi
1373         tmp_hi_file <- if doing_hi
1374                           then do fn <- newTempName "hi"
1375                                   add files_to_clean fn
1376                                   return fn
1377                           else return ""
1378
1379         let hi_flag = if doing_hi then "-hifile=" ++ tmp_hi_file
1380                                   else ""
1381
1382   -- deal with -Rghc-timing
1383         timing <- readIORef collect_ghc_timing
1384         stat_file <- newTempName "stat"
1385         add files_to_clean stat_file
1386         let stat_opts | timing    = [ "+RTS", "-S"++stat_file, "-RTS" ]
1387                       | otherwise = []
1388
1389   -- tmp files for foreign export stub code
1390         tmp_stub_h <- newTempName "stub_h"
1391         tmp_stub_c <- newTempName "stub_c"
1392         add files_to_clean tmp_stub_h
1393         add files_to_clean tmp_stub_c
1394
1395   -- figure out where to put the .hi file
1396         ohi    <- readIORef output_hi
1397         hisuf  <- readIORef hi_suf
1398         let hi_flags = case ohi of
1399                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
1400                            Just fn -> [ "-hifile="++fn ]
1401
1402   -- run the compiler!
1403         run_something "Haskell Compiler"
1404                  (unwords (hsc : input_fn : (
1405                     hsc_opts
1406                     ++ hi_flags
1407                     ++ [
1408                           "-ofile="++output_fn,
1409                           "-F="++tmp_stub_c,
1410                           "-FH="++tmp_stub_h
1411                        ]
1412                     ++ stat_opts
1413                  )))
1414
1415   -- Generate -Rghc-timing info
1416         on (timing) (
1417             run_something "Generate timing stats"
1418                 (findFile "ghc-stats" cGHC_STATS ++ ' ':stat_file)
1419          )
1420
1421   -- Deal with stubs
1422         let stub_h = basename ++ "_stub.h"
1423         let stub_c = basename ++ "_stub.c"
1424
1425                 -- copy .h_stub file into current dir if present
1426         b <- fileExist tmp_stub_h
1427         on b (do
1428                 run_something "Copy stub .h file"
1429                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
1430
1431                         -- #include <..._stub.h> in .hc file
1432                 add cmdline_hc_includes tmp_stub_h      -- hack
1433
1434                         -- copy the _stub.c file into the current dir
1435                 run_something "Copy stub .c file"
1436                     (unwords [
1437                         "rm -f", stub_c, "&&",
1438                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
1439                         "cat", tmp_stub_c, ">> ", stub_c
1440                         ])
1441
1442                         -- compile the _stub.c file w/ gcc
1443                 run_pipeline As False{-no linking-}
1444                                 False{-no -o option-}
1445                                 (basename++"_stub")
1446                                 (Cc, stub_c)
1447
1448                 add ld_inputs (basename++"_stub.o")
1449          )
1450
1451 -----------------------------------------------------------------------------
1452 -- Cc phase
1453
1454 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
1455 -- way too many hacks, and I can't say I've ever used it anyway.
1456
1457 run_phase cc_phase basename input_fn output_fn
1458    | cc_phase == Cc || cc_phase == HCc
1459    = do cc <- readIORef pgm_c
1460         cc_opts <- getOpts opt_c
1461         cmdline_include_dirs <- readIORef include_paths
1462        -- ToDo: $c_flags .= " -mno-cygwin" if ( $TargetPlatform =~ /-mingw32$/ );
1463
1464         let hcc = cc_phase == HCc
1465
1466                 -- add package include paths even if we're just compiling
1467                 -- .c files; this is the Value Add(TM) that using
1468                 -- ghc instead of gcc gives you :)
1469         pkg_include_dirs <- getPackageIncludePath
1470         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
1471                                                         ++ pkg_include_dirs)
1472
1473         c_includes <- getPackageCIncludes
1474         cmdline_includes <- readIORef cmdline_hc_includes -- -#include options
1475
1476         let cc_injects | hcc = unlines (map mk_include
1477                                         (c_includes ++ reverse cmdline_includes))
1478                        | otherwise = ""
1479             mk_include h_file =
1480                 case h_file of
1481                    '"':_{-"-} -> "#include "++h_file
1482                    '<':_      -> "#include "++h_file
1483                    _          -> "#include \""++h_file++"\""
1484
1485         cc_help <- newTempName "c"
1486         add files_to_clean cc_help
1487         h <- openFile cc_help WriteMode
1488         hPutStr h cc_injects
1489         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
1490         hClose h
1491
1492         ccout <- newTempName "ccout"
1493         add files_to_clean ccout
1494
1495         mangle <- readIORef do_asm_mangling
1496         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
1497
1498         verb <- is_verbose
1499
1500         o2 <- readIORef opt_minus_o2_for_C
1501         let opt_flag | o2        = "-O2"
1502                      | otherwise = "-O"
1503
1504         pkg_extra_cc_opts <- getPackageExtraCcOpts
1505
1506         run_something "C Compiler"
1507          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
1508                    ++ md_c_flags
1509                    ++ (if cc_phase == HCc && mangle
1510                          then md_regd_c_flags
1511                          else [])
1512                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
1513                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1514                    ++ cc_opts
1515                    ++ include_paths
1516                    ++ pkg_extra_cc_opts
1517 --                 ++ [">", ccout]
1518                    ))
1519
1520         -- ToDo: postprocess the output from gcc
1521
1522 -----------------------------------------------------------------------------
1523 -- Mangle phase
1524
1525 run_phase Mangle basename input_fn output_fn
1526   = do mangler <- readIORef pgm_m
1527        mangler_opts <- getOpts opt_m
1528        machdep_opts <-
1529          if (prefixMatch "i386" cTARGETPLATFORM)
1530             then do n_regs <- readIORef stolen_x86_regs
1531                     return [ show n_regs ]
1532             else return []
1533        run_something "Assembly Mangler"
1534         (unwords (mangler :
1535                      mangler_opts
1536                   ++ [ input_fn, output_fn ]
1537                   ++ machdep_opts
1538                 ))
1539
1540 -----------------------------------------------------------------------------
1541 -- Splitting phase
1542
1543 run_phase SplitMangle basename input_fn outputfn
1544   = do  splitter <- readIORef pgm_s
1545
1546         -- this is the prefix used for the split .s files
1547         tmp_pfx <- readIORef tmp_prefix
1548         x <- getProcessID
1549         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1550         writeIORef split_prefix split_s_prefix
1551         add files_to_clean (split_s_prefix ++ "__*") -- d:-)
1552
1553         -- allocate a tmp file to put the no. of split .s files in (sigh)
1554         n_files <- newTempName "n_files"
1555         add files_to_clean n_files
1556
1557         run_something "Split Assembly File"
1558          (unwords [ splitter
1559                   , input_fn
1560                   , split_s_prefix
1561                   , n_files ]
1562          )
1563
1564         -- save the number of split files for future references
1565         s <- readFile n_files
1566         let n = read s :: Int
1567         writeIORef n_split_files n
1568
1569 -----------------------------------------------------------------------------
1570 -- As phase
1571
1572 run_phase As basename input_fn output_fn
1573   = do  as <- readIORef pgm_a
1574         as_opts <- getOpts opt_a
1575
1576         cmdline_include_paths <- readIORef include_paths
1577         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1578         run_something "Assembler"
1579            (unwords (as : as_opts
1580                        ++ cmdline_include_flags
1581                        ++ [ "-c", input_fn, "-o",  output_fn ]
1582                     ))
1583
1584 run_phase SplitAs basename input_fn output_fn
1585   = do  as <- readIORef pgm_a
1586         as_opts <- getOpts opt_a
1587
1588         odir_opt <- readIORef output_dir
1589         let odir | Just s <- odir_opt = s
1590                      | otherwise          = basename
1591
1592         split_s_prefix <- readIORef split_prefix
1593         n <- readIORef n_split_files
1594
1595         odir <- readIORef output_dir
1596         let real_odir = case odir of
1597                                 Nothing -> basename
1598                                 Just d  -> d
1599
1600         let assemble_file n = do
1601                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
1602                     let output_o = newdir real_odir
1603                                         (basename ++ "__" ++ show n ++ ".o")
1604                     real_o <- osuf_ify output_o
1605                     run_something "Assembler"
1606                             (unwords (as : as_opts
1607                                       ++ [ "-c", "-o", real_o, input_s ]
1608                             ))
1609
1610         mapM_ assemble_file [1..n]
1611
1612 -----------------------------------------------------------------------------
1613 -- Linking
1614
1615 do_link :: [String] -> [String] -> IO ()
1616 do_link o_files unknown_srcs = do
1617     ln <- readIORef pgm_l
1618     verb <- is_verbose
1619     o_file <- readIORef output_file
1620     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1621
1622     pkg_lib_paths <- getPackageLibraryPath
1623     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1624
1625     lib_paths <- readIORef library_paths
1626     let lib_path_opts = map ("-L"++) lib_paths
1627
1628     pkg_libs <- getPackageLibraries
1629     let pkg_lib_opts = map ("-l"++) pkg_libs
1630
1631     libs <- readIORef cmdline_libraries
1632     let lib_opts = map ("-l"++) (reverse libs)
1633          -- reverse because they're added in reverse order from the cmd line
1634
1635     pkg_extra_ld_opts <- getPackageExtraLdOpts
1636
1637         -- probably _stub.o files
1638     extra_ld_inputs <- readIORef ld_inputs
1639
1640         -- opts from -optl-<blah>
1641     extra_ld_opts <- getOpts opt_l
1642
1643     run_something "Linker"
1644        (unwords
1645          ([ ln, verb, "-o", output_fn ]
1646          ++ o_files
1647          ++ unknown_srcs
1648          ++ extra_ld_inputs
1649          ++ lib_path_opts
1650          ++ lib_opts
1651          ++ pkg_lib_path_opts
1652          ++ pkg_lib_opts
1653          ++ pkg_extra_ld_opts
1654          ++ extra_ld_opts
1655         )
1656        )
1657
1658 -----------------------------------------------------------------------------
1659 -- Running an external program
1660
1661 run_something phase_name cmd
1662  = do
1663    verb <- readIORef verbose
1664    when verb $ do
1665         putStr phase_name
1666         putStrLn ":"
1667         putStrLn cmd
1668
1669    -- test for -n flag
1670    n <- readIORef dry_run
1671    unless n $ do
1672
1673    -- and run it!
1674    exit_code <- system cmd  `catchAllIO`
1675                    (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
1676
1677    if exit_code /= ExitSuccess
1678         then throwDyn (PhaseFailed phase_name exit_code)
1679         else do on verb (putStr "\n")
1680                 return ()
1681
1682 -----------------------------------------------------------------------------
1683 -- Flags
1684
1685 data OptKind
1686         = NoArg (IO ())                 -- flag with no argument
1687         | HasArg (String -> IO ())      -- flag has an argument (maybe prefix)
1688         | SepArg (String -> IO ())      -- flag has a separate argument
1689         | Prefix (String -> IO ())      -- flag is a prefix only
1690         | OptPrefix (String -> IO ())   -- flag may be a prefix
1691         | AnySuffix (String -> IO ())   -- flag is a prefix, pass whole arg to fn
1692         | PassFlag  (String -> IO ())   -- flag with no arg, pass flag to fn
1693
1694 -- note that ordering is important in the following list: any flag which
1695 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
1696 -- flags further down the list with the same prefix.
1697
1698 opts =
1699   [  ------- help -------------------------------------------------------
1700      ( "?"              , NoArg long_usage)
1701   ,  ( "-help"          , NoArg long_usage)
1702
1703
1704       ------- version ----------------------------------------------------
1705   ,  ( "-version"        , NoArg (do hPutStrLn stderr (cProjectName
1706                                       ++ ", version " ++ version_str)
1707                                      exitWith ExitSuccess))
1708   ,  ( "-numeric-version", NoArg (do hPutStrLn stderr version_str
1709                                      exitWith ExitSuccess))
1710
1711       ------- verbosity ----------------------------------------------------
1712   ,  ( "v"              , NoArg (writeIORef verbose True) )
1713   ,  ( "n"              , NoArg (writeIORef dry_run True) )
1714
1715         ------- recompilation checker --------------------------------------
1716   ,  ( "recomp"         , NoArg (writeIORef recomp True) )
1717   ,  ( "no-recomp"      , NoArg (writeIORef recomp False) )
1718
1719         ------- ways --------------------------------------------------------
1720   ,  ( "prof"           , NoArg (addNoDups ways WayProf) )
1721   ,  ( "unreg"          , NoArg (addNoDups ways WayUnreg) )
1722   ,  ( "ticky"          , NoArg (addNoDups ways WayTicky) )
1723   ,  ( "parallel"       , NoArg (addNoDups ways WayPar) )
1724   ,  ( "gransim"        , NoArg (addNoDups ways WayGran) )
1725   ,  ( "smp"            , NoArg (addNoDups ways WaySMP) )
1726   ,  ( "debug"          , NoArg (addNoDups ways WayDebug) )
1727         -- ToDo: user ways
1728
1729         ------- Interface files ---------------------------------------------
1730   ,  ( "hi"             , NoArg (writeIORef produceHi True) )
1731   ,  ( "nohi"           , NoArg (writeIORef produceHi False) )
1732   ,  ( "hi-diffs"       , NoArg (writeIORef hi_diffs  NormalHiDiffs) )
1733   ,  ( "no-hi-diffs"    , NoArg (writeIORef hi_diffs  NoHiDiffs) )
1734   ,  ( "hi-diffs-with-usages" , NoArg (writeIORef hi_diffs UsageHiDiffs) )
1735   ,  ( "keep-hi-diffs"  , NoArg (writeIORef keep_hi_diffs True) )
1736         --"hi-with-*"    -> hiw <- readIORef hi_with  (ToDo)
1737
1738         --------- Profiling --------------------------------------------------
1739   ,  ( "auto-dicts"     , NoArg (add opt_C "-fauto-sccs-on-dicts") )
1740   ,  ( "auto-all"       , NoArg (add opt_C "-fauto-sccs-on-all-toplevs") )
1741   ,  ( "auto"           , NoArg (add opt_C "-fauto-sccs-on-exported-toplevs") )
1742   ,  ( "caf-all"        , NoArg (add opt_C "-fauto-sccs-on-individual-cafs") )
1743          -- "ignore-sccs"  doesn't work  (ToDo)
1744
1745         ------- Miscellaneous -----------------------------------------------
1746   ,  ( "cpp"            , NoArg (writeIORef cpp_flag True) )
1747   ,  ( "#include"       , HasArg (add cmdline_hc_includes) )
1748   ,  ( "no-link-chk"    , NoArg (return ()) ) -- ignored for backwards compat
1749
1750         ------- Output Redirection ------------------------------------------
1751   ,  ( "odir"           , HasArg (writeIORef output_dir  . Just) )
1752   ,  ( "o"              , SepArg (writeIORef output_file . Just) )
1753   ,  ( "osuf"           , HasArg (writeIORef output_suf  . Just) )
1754   ,  ( "hisuf"          , HasArg (writeIORef hi_suf) )
1755   ,  ( "tmpdir"         , HasArg (writeIORef tmp_prefix  . (++ "/")) )
1756   ,  ( "ohi"            , HasArg (\s -> case s of
1757                                           "-" -> writeIORef hi_on_stdout True
1758                                           _   -> writeIORef output_hi (Just s)) )
1759         -- -odump?
1760
1761   ,  ( "keep-hc-file"   , AnySuffix (\_ -> writeIORef keep_hc_files True) )
1762   ,  ( "keep-s-file"    , AnySuffix (\_ -> writeIORef keep_s_files  True) )
1763   ,  ( "keep-raw-s-file", AnySuffix (\_ -> writeIORef keep_raw_s_files  True) )
1764   ,  ( "keep-tmp-files" , AnySuffix (\_ -> writeIORef keep_tmp_files True) )
1765
1766   ,  ( "split-objs"     , NoArg (if can_split
1767                                     then do writeIORef split_object_files True
1768                                             add opt_C "-fglobalise-toplev-names"
1769                                             add opt_c "-DUSE_SPLIT_MARKERS"
1770                                     else hPutStrLn stderr
1771                                             "warning: don't know how to  split \
1772                                             \object files on this architecture"
1773                                 ) )
1774
1775         ------- Include/Import Paths ----------------------------------------
1776   ,  ( "i"              , OptPrefix augment_import_paths )
1777   ,  ( "I"              , Prefix augment_include_paths )
1778
1779         ------- Libraries ---------------------------------------------------
1780   ,  ( "L"              , Prefix augment_library_paths )
1781   ,  ( "l"              , Prefix (add cmdline_libraries) )
1782
1783         ------- Packages ----------------------------------------------------
1784   ,  ( "package-name"   , HasArg (\s -> add opt_C ("-inpackage="++s)) )
1785
1786   ,  ( "package"        , HasArg (addPackage) )
1787   ,  ( "syslib"         , HasArg (addPackage) ) -- for compatibility w/ old vsns
1788
1789   ,  ( "-list-packages"  , NoArg (listPackages) )
1790   ,  ( "-add-package"    , NoArg (newPackage) )
1791   ,  ( "-delete-package" , SepArg (deletePackage) )
1792
1793         ------- Specific phases  --------------------------------------------
1794   ,  ( "pgmdep"         , HasArg (writeIORef pgm_dep) )
1795   ,  ( "pgmL"           , HasArg (writeIORef pgm_L) )
1796   ,  ( "pgmP"           , HasArg (writeIORef pgm_P) )
1797   ,  ( "pgmC"           , HasArg (writeIORef pgm_C) )
1798   ,  ( "pgmc"           , HasArg (writeIORef pgm_c) )
1799   ,  ( "pgmm"           , HasArg (writeIORef pgm_m) )
1800   ,  ( "pgms"           , HasArg (writeIORef pgm_s) )
1801   ,  ( "pgma"           , HasArg (writeIORef pgm_a) )
1802   ,  ( "pgml"           , HasArg (writeIORef pgm_l) )
1803
1804   ,  ( "optdep"         , HasArg (add opt_dep) )
1805   ,  ( "optL"           , HasArg (add opt_L) )
1806   ,  ( "optP"           , HasArg (add opt_P) )
1807   ,  ( "optCrts"        , HasArg (add opt_Crts) )
1808   ,  ( "optC"           , HasArg (add opt_C) )
1809   ,  ( "optc"           , HasArg (add opt_c) )
1810   ,  ( "optm"           , HasArg (add opt_m) )
1811   ,  ( "opta"           , HasArg (add opt_a) )
1812   ,  ( "optl"           , HasArg (add opt_l) )
1813   ,  ( "optdll"         , HasArg (add opt_dll) )
1814
1815         ------ HsCpp opts ---------------------------------------------------
1816   ,  ( "D"              , Prefix (\s -> add opt_P ("-D'"++s++"'") ) )
1817   ,  ( "U"              , Prefix (\s -> add opt_P ("-U'"++s++"'") ) )
1818
1819         ------ Warning opts -------------------------------------------------
1820   ,  ( "W"              , NoArg (writeIORef warning_opt W_))
1821   ,  ( "Wall"           , NoArg (writeIORef warning_opt W_all))
1822   ,  ( "Wnot"           , NoArg (writeIORef warning_opt W_not))
1823   ,  ( "w"              , NoArg (writeIORef warning_opt W_not))
1824
1825         ----- Linker --------------------------------------------------------
1826   ,  ( "static"         , NoArg (writeIORef static True) )
1827
1828         ------ Compiler RTS options -----------------------------------------
1829   ,  ( "H"                 , HasArg (sizeOpt specific_heap_size) )
1830   ,  ( "K"                 , HasArg (sizeOpt specific_stack_size) )
1831   ,  ( "Rscale-sizes"      , HasArg (floatOpt scale_sizes_by) )
1832   ,  ( "Rghc-timing"       , NoArg (writeIORef collect_ghc_timing True) )
1833
1834         ------ Debugging ----------------------------------------------------
1835   ,  ( "dstg-stats"        , NoArg (writeIORef opt_StgStats True) )
1836
1837   ,  ( "dno-"              , Prefix (\s -> add anti_opt_C ("-d"++s)) )
1838   ,  ( "d"                 , AnySuffix (add opt_C) )
1839
1840         ------ Machine dependant (-m<blah>) stuff ---------------------------
1841
1842   ,  ( "monly-2-regs",          NoArg (writeIORef stolen_x86_regs 2) )
1843   ,  ( "monly-3-regs",          NoArg (writeIORef stolen_x86_regs 3) )
1844   ,  ( "monly-4-regs",          NoArg (writeIORef stolen_x86_regs 4) )
1845
1846         ------ Compiler flags -----------------------------------------------
1847   ,  ( "O2-for-C"          , NoArg (writeIORef opt_minus_o2_for_C True) )
1848   ,  ( "O"                 , OptPrefix (setOptLevel) )
1849
1850   ,  ( "fglasgow-exts-no-lang", NoArg ( do add opt_C "-fglasgow-exts") )
1851
1852   ,  ( "fglasgow-exts"     , NoArg (do add opt_C "-fglasgow-exts"
1853                                        addPackage "lang"))
1854
1855   ,  ( "fasm"              , OptPrefix (\_ -> writeIORef hsc_lang HscAsm) )
1856
1857   ,  ( "fvia-C"            , NoArg (writeIORef hsc_lang HscC) )
1858
1859   ,  ( "fno-asm-mangling"  , NoArg (writeIORef do_asm_mangling False) )
1860
1861   ,  ( "fmax-simplifier-iterations",
1862                 Prefix (writeIORef opt_MaxSimplifierIterations . read) )
1863
1864   ,  ( "fusagesp"          , NoArg (do writeIORef opt_UsageSPInf True
1865                                        add opt_C "-fusagesp-on") )
1866
1867   ,  ( "fstrictfp"         , NoArg (do add opt_C "-fstrictfp"
1868                                        add opt_c "-ffloat-store"))
1869
1870         -- flags that are "active negatives"
1871   ,  ( "fno-implicit-prelude"   , PassFlag (add opt_C) )
1872   ,  ( "fno-prune-tydecls"      , PassFlag (add opt_C) )
1873   ,  ( "fno-prune-instdecls"    , PassFlag (add opt_C) )
1874   ,  ( "fno-pre-inlining"       , PassFlag (add opt_C) )
1875
1876         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
1877   ,  ( "fno-",                  Prefix (\s -> add anti_opt_C ("-f"++s)) )
1878
1879         -- Pass all remaining "-f<blah>" options to hsc
1880   ,  ( "f",                     AnySuffix (add opt_C) )
1881   ]
1882
1883 -----------------------------------------------------------------------------
1884 -- Process command-line
1885
1886 processArgs :: [String] -> [String] -> IO [String]  -- returns spare args
1887 processArgs [] spare = return (reverse spare)
1888 processArgs args@(('-':_):_) spare = do
1889   args' <- processOneArg args
1890   processArgs args' spare
1891 processArgs (arg:args) spare =
1892   processArgs args (arg:spare)
1893
1894 processOneArg :: [String] -> IO [String]
1895 processOneArg (('-':arg):args) = do
1896   let (rest,action) = findArg arg
1897       dash_arg = '-':arg
1898   case action of
1899
1900         NoArg  io ->
1901                 if rest == ""
1902                         then io >> return args
1903                         else throwDyn (UnknownFlag dash_arg)
1904
1905         HasArg fio ->
1906                 if rest /= ""
1907                         then fio rest >> return args
1908                         else case args of
1909                                 [] -> throwDyn (UnknownFlag dash_arg)
1910                                 (arg1:args1) -> fio arg1 >> return args1
1911
1912         SepArg fio ->
1913                 case args of
1914                         [] -> throwDyn (UnknownFlag dash_arg)
1915                         (arg1:args1) -> fio arg1 >> return args1
1916
1917         Prefix fio ->
1918                 if rest /= ""
1919                         then fio rest >> return args
1920                         else throwDyn (UnknownFlag dash_arg)
1921
1922         OptPrefix fio -> fio rest >> return args
1923
1924         AnySuffix fio -> fio ('-':arg) >> return args
1925
1926         PassFlag fio  ->
1927                 if rest /= ""
1928                         then throwDyn (UnknownFlag dash_arg)
1929                         else fio ('-':arg) >> return args
1930
1931 findArg :: String -> (String,OptKind)
1932 findArg arg
1933   = case [ (remove_spaces rest, k) | (pat,k) <- opts,
1934                                      Just rest <- [my_prefix_match pat arg],
1935                                      is_prefix k || null rest ] of
1936         [] -> throwDyn (UnknownFlag ('-':arg))
1937         (one:_) -> one
1938
1939 is_prefix (NoArg _) = False
1940 is_prefix (SepArg _) = False
1941 is_prefix (PassFlag _) = False
1942 is_prefix _ = True
1943
1944 -----------------------------------------------------------------------------
1945 -- convert sizes like "3.5M" into integers
1946
1947 sizeOpt :: IORef Integer -> String -> IO ()
1948 sizeOpt ref str
1949   | c == ""              = writeSizeOpt ref (truncate n)
1950   | c == "K" || c == "k" = writeSizeOpt ref (truncate (n * 1000))
1951   | c == "M" || c == "m" = writeSizeOpt ref (truncate (n * 1000 * 1000))
1952   | c == "G" || c == "g" = writeSizeOpt ref (truncate (n * 1000 * 1000 * 1000))
1953   | otherwise            = throwDyn (UnknownFlag str)
1954   where (m, c) = span pred str
1955         n      = read m  :: Double
1956         pred c = isDigit c || c == '.'
1957
1958 writeSizeOpt :: IORef Integer -> Integer -> IO ()
1959 writeSizeOpt ref new = do
1960   current <- readIORef ref
1961   when (new > current) $
1962         writeIORef ref new
1963
1964 floatOpt :: IORef Double -> String -> IO ()
1965 floatOpt ref str
1966   = writeIORef ref (read str :: Double)
1967
1968 -----------------------------------------------------------------------------
1969 -- Finding files in the installation
1970
1971 GLOBAL_VAR(topDir, clibdir, String)
1972
1973         -- grab the last -B option on the command line, and
1974         -- set topDir to its value.
1975 setTopDir :: [String] -> IO [String]
1976 setTopDir args = do
1977   let (minusbs, others) = partition (prefixMatch "-B") args
1978   (case minusbs of
1979     []   -> writeIORef topDir clibdir
1980     some -> writeIORef topDir (drop 2 (last some)))
1981   return others
1982
1983 findFile name alt_path = unsafePerformIO (do
1984   top_dir <- readIORef topDir
1985   let installed_file = top_dir ++ '/':name
1986   let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
1987   b <- fileExist inplace_file
1988   if b  then return inplace_file
1989         else return installed_file
1990  )
1991
1992 -----------------------------------------------------------------------------
1993 -- Utils
1994
1995 my_partition :: (a -> Maybe b) -> [a] -> ([b],[a])
1996 my_partition p [] = ([],[])
1997 my_partition p (a:as)
1998   = let (bs,cs) = my_partition p as in
1999     case p a of
2000         Nothing -> (bs,a:cs)
2001         Just b  -> (b:bs,cs)
2002
2003 my_prefix_match :: String -> String -> Maybe String
2004 my_prefix_match [] rest = Just rest
2005 my_prefix_match (p:pat) [] = Nothing
2006 my_prefix_match (p:pat) (r:rest)
2007   | p == r    = my_prefix_match pat rest
2008   | otherwise = Nothing
2009
2010 prefixMatch :: Eq a => [a] -> [a] -> Bool
2011 prefixMatch [] str = True
2012 prefixMatch pat [] = False
2013 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
2014                           | otherwise = False
2015
2016 postfixMatch :: String -> String -> Bool
2017 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
2018
2019 later = flip finally
2020
2021 on b io = if b then io >> return (error "on") else return (error "on")
2022
2023 my_catch = flip catchAllIO
2024 my_catchDyn = flip catchDyn
2025
2026 global :: a -> IORef a
2027 global a = unsafePerformIO (newIORef a)
2028
2029 split_filename :: String -> (String,String)
2030 split_filename f = (reverse (stripDot rev_basename), reverse rev_ext)
2031   where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
2032         stripDot ('.':xs) = xs
2033         stripDot xs       = xs
2034
2035 split :: Char -> String -> [String]
2036 split c s = case rest of
2037                 []     -> [chunk]
2038                 _:rest -> chunk : split c rest
2039   where (chunk, rest) = break (==c) s
2040
2041 add :: IORef [a] -> a -> IO ()
2042 add var x = do
2043   xs <- readIORef var
2044   writeIORef var (x:xs)
2045
2046 addNoDups :: Eq a => IORef [a] -> a -> IO ()
2047 addNoDups var x = do
2048   xs <- readIORef var
2049   unless (x `elem` xs) $ writeIORef var (x:xs)
2050
2051 remove_suffix :: String -> Char -> String
2052 remove_suffix s c
2053   | null pre  = reverse suf
2054   | otherwise = reverse pre
2055   where (suf,pre) = break (==c) (reverse s)
2056
2057 drop_longest_prefix :: String -> Char -> String
2058 drop_longest_prefix s c = reverse suf
2059   where (suf,pre) = break (==c) (reverse s)
2060
2061 take_longest_prefix :: String -> Char -> String
2062 take_longest_prefix s c = reverse pre
2063   where (suf,pre) = break (==c) (reverse s)
2064
2065 newsuf :: String -> String -> String
2066 newsuf suf s = remove_suffix s '.' ++ suf
2067
2068 -- getdir strips the filename off the input string, returning the directory.
2069 getdir :: String -> String
2070 getdir s = if null dir then "." else init dir
2071   where dir = take_longest_prefix s '/'
2072
2073 newdir :: String -> String -> String
2074 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
2075
2076 remove_spaces :: String -> String
2077 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace