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