ghc/driver/Main.hs

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