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