ghc/driver/Main.hs

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