ghc/Main.hs

   1 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
   2
   3 -----------------------------------------------------------------------------
   4 --
   5 -- GHC Driver program
   6 --
   7 -- (c) The University of Glasgow 2005
   8 --
   9 -----------------------------------------------------------------------------
  10
  11 module Main (main) where
  12
  13 -- The official GHC API
  14 import qualified GHC
  15 import GHC              ( -- DynFlags(..), HscTarget(..),
  16                           -- GhcMode(..), GhcLink(..),
  17                           Ghc, GhcMonad(..),
  18                           LoadHowMuch(..) )
  19 import CmdLineParser
  20
  21 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
  22 import LoadIface        ( showIface )
  23 import HscMain          ( newHscEnv )
  24 import DriverPipeline   ( oneShot, compileFile )
  25 import DriverMkDepend   ( doMkDependHS )
  26 #ifdef GHCI
  27 import InteractiveUI    ( interactiveUI, ghciWelcomeMsg )
  28 #endif
  29
  30
  31 -- Various other random stuff that we need
  32 import Config
  33 import HscTypes
  34 import Packages         ( dumpPackages )
  35 import DriverPhases     ( Phase(..), isSourceFilename, anyHsc,
  36                           startPhase, isHaskellSrcFilename )
  37 import BasicTypes       ( failed )
  38 import StaticFlags
  39 import StaticFlagParser
  40 import DynFlags
  41 import ErrUtils
  42 import FastString
  43 import Outputable
  44 import SrcLoc
  45 import Util
  46 import Panic
  47 import MonadUtils       ( liftIO )
  48
  49 -- Imports for --abi-hash
  50 import LoadIface           ( loadUserInterface )
  51 import Module              ( mkModuleName )
  52 import Finder              ( findImportedModule, cannotFindInterface )
  53 import TcRnMonad           ( initIfaceCheck )
  54 import Binary              ( openBinMem, put_, fingerprintBinMem )
  55
  56 -- Standard Haskell libraries
  57 import System.IO
  58 import System.Environment
  59 import System.Exit
  60 import System.FilePath
  61 import Control.Monad
  62 import Data.Char
  63 import Data.List
  64 import Data.Maybe
  65
  66 -----------------------------------------------------------------------------
  67 -- ToDo:
  68
  69 -- time commands when run with -v
  70 -- user ways
  71 -- Win32 support: proper signal handling
  72 -- reading the package configuration file is too slow
  73 -- -K<size>
  74
  75 -----------------------------------------------------------------------------
  76 -- GHC's command-line interface
  77
  78 main :: IO ()
  79 main = do
  80    hSetBuffering stdout NoBuffering
  81    let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings")
  82    GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do
  83     -- 1. extract the -B flag from the args
  84     argv0 <- getArgs
  85
  86     let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
  87         mbMinusB | null minusB_args = Nothing
  88                  | otherwise = Just (drop 2 (last minusB_args))
  89
  90     let argv1' = map (mkGeneralLocated "on the commandline") argv1
  91     (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
  92
  93     -- 2. Parse the "mode" flags (--make, --interactive etc.)
  94     (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
  95
  96     let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
  97
  98     -- If all we want to do is something like showing the version number
  99     -- then do it now, before we start a GHC session etc. This makes
 100     -- getting basic information much more resilient.
 101
 102     -- In particular, if we wait until later before giving the version
 103     -- number then bootstrapping gets confused, as it tries to find out
 104     -- what version of GHC it's using before package.conf exists, so
 105     -- starting the session fails.
 106     case mode of
 107         Left preStartupMode ->
 108             do case preStartupMode of
 109                    ShowSupportedExtensions -> showSupportedExtensions
 110                    ShowVersion             -> showVersion
 111                    ShowNumVersion          -> putStrLn cProjectVersion
 112                    Print str               -> putStrLn str
 113         Right postStartupMode ->
 114             -- start our GHC session
 115             GHC.runGhc mbMinusB $ do
 116
 117             dflags <- GHC.getSessionDynFlags
 118
 119             case postStartupMode of
 120                 Left preLoadMode ->
 121                     liftIO $ do
 122                         case preLoadMode of
 123                             ShowInfo               -> showInfo dflags
 124                             ShowGhcUsage           -> showGhcUsage  dflags
 125                             ShowGhciUsage          -> showGhciUsage dflags
 126                             PrintWithDynFlags f    -> putStrLn (f dflags)
 127                 Right postLoadMode ->
 128                     main' postLoadMode dflags argv3 flagWarnings
 129
 130 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
 131       -> Ghc ()
 132 main' postLoadMode dflags0 args flagWarnings = do
 133   -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
 134   -- can be further adjusted on a module by module basis, using only
 135   -- the -fvia-C and -fasm flags.  If the default HscTarget is not
 136   -- HscC or HscAsm, -fvia-C and -fasm have no effect.
 137   let dflt_target = hscTarget dflags0
 138       (mode, lang, link)
 139          = case postLoadMode of
 140                DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
 141                DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
 142                DoMake          -> (CompManager, dflt_target,    LinkBinary)
 143                DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
 144                DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
 145                _               -> (OneShot,     dflt_target,    LinkBinary)
 146
 147   let dflags1 = dflags0{ ghcMode   = mode,
 148                          hscTarget = lang,
 149                          ghcLink   = link,
 150                          -- leave out hscOutName for now
 151                          hscOutName = panic "Main.main:hscOutName not set",
 152                          verbosity = case postLoadMode of
 153                                          DoEval _ -> 0
 154                                          _other   -> 1
 155                         }
 156
 157       -- turn on -fimplicit-import-qualified for GHCi now, so that it
 158       -- can be overriden from the command-line
 159       dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled
 160                | DoEval _      <- postLoadMode = imp_qual_enabled
 161                | otherwise                 = dflags1
 162         where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified
 163
 164         -- The rest of the arguments are "dynamic"
 165         -- Leftover ones are presumably files
 166   (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
 167
 168   let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
 169
 170   handleSourceError (\e -> do
 171        GHC.printException e
 172        liftIO $ exitWith (ExitFailure 1)) $ do
 173          liftIO $ handleFlagWarnings dflags2 flagWarnings'
 174
 175         -- make sure we clean up after ourselves
 176   GHC.defaultCleanupHandler dflags2 $ do
 177
 178   liftIO $ showBanner postLoadMode dflags2
 179
 180   -- we've finished manipulating the DynFlags, update the session
 181   _ <- GHC.setSessionDynFlags dflags2
 182   dflags3 <- GHC.getSessionDynFlags
 183   hsc_env <- GHC.getSession
 184
 185   let
 186      -- To simplify the handling of filepaths, we normalise all filepaths right
 187      -- away - e.g., for win32 platforms, backslashes are converted
 188      -- into forward slashes.
 189     normal_fileish_paths = map (normalise . unLoc) fileish_args
 190     (srcs, objs)         = partition_args normal_fileish_paths [] []
 191
 192   -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
 193   --       the command-line.
 194   liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)
 195
 196         ---------------- Display configuration -----------
 197   when (verbosity dflags3 >= 4) $
 198         liftIO $ dumpPackages dflags3
 199
 200   when (verbosity dflags3 >= 3) $ do
 201         liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
 202
 203         ---------------- Final sanity checking -----------
 204   liftIO $ checkOptions postLoadMode dflags3 srcs objs
 205
 206   ---------------- Do the business -----------
 207   handleSourceError (\e -> do
 208        GHC.printException e
 209        liftIO $ exitWith (ExitFailure 1)) $ do
 210     case postLoadMode of
 211        ShowInterface f        -> liftIO $ doShowIface dflags3 f
 212        DoMake                 -> doMake srcs
 213        DoMkDependHS           -> doMkDependHS (map fst srcs)
 214        StopBefore p           -> liftIO (oneShot hsc_env p srcs)
 215        DoInteractive          -> interactiveUI srcs Nothing
 216        DoEval exprs           -> interactiveUI srcs $ Just $ reverse exprs
 217        DoAbiHash              -> abiHash srcs
 218
 219   liftIO $ dumpFinalStats dflags3
 220
 221 #ifndef GHCI
 222 interactiveUI :: b -> c -> Ghc ()
 223 interactiveUI _ _ =
 224   ghcError (CmdLineError "not built for interactive use")
 225 #endif
 226
 227 -- -----------------------------------------------------------------------------
 228 -- Splitting arguments into source files and object files.  This is where we
 229 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
 230 -- file indicating the phase specified by the -x option in force, if any.
 231
 232 partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
 233                -> ([(String, Maybe Phase)], [String])
 234 partition_args [] srcs objs = (reverse srcs, reverse objs)
 235 partition_args ("-x":suff:args) srcs objs
 236   | "none" <- suff      = partition_args args srcs objs
 237   | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
 238   | otherwise           = partition_args rest (these_srcs ++ srcs) objs
 239         where phase = startPhase suff
 240               (slurp,rest) = break (== "-x") args
 241               these_srcs = zip slurp (repeat (Just phase))
 242 partition_args (arg:args) srcs objs
 243   | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
 244   | otherwise               = partition_args args srcs (arg:objs)
 245
 246     {-
 247       We split out the object files (.o, .dll) and add them
 248       to v_Ld_inputs for use by the linker.
 249
 250       The following things should be considered compilation manager inputs:
 251
 252        - haskell source files (strings ending in .hs, .lhs or other
 253          haskellish extension),
 254
 255        - module names (not forgetting hierarchical module names),
 256
 257        - and finally we consider everything not containing a '.' to be
 258          a comp manager input, as shorthand for a .hs or .lhs filename.
 259
 260       Everything else is considered to be a linker object, and passed
 261       straight through to the linker.
 262     -}
 263 looks_like_an_input :: String -> Bool
 264 looks_like_an_input m =  isSourceFilename m
 265                       || looksLikeModuleName m
 266                       || '.' `notElem` m
 267
 268 -- -----------------------------------------------------------------------------
 269 -- Option sanity checks
 270
 271 -- | Ensure sanity of options.
 272 --
 273 -- Throws 'UsageError' or 'CmdLineError' if not.
 274 checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
 275      -- Final sanity checking before kicking off a compilation (pipeline).
 276 checkOptions mode dflags srcs objs = do
 277      -- Complain about any unknown flags
 278    let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
 279    when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
 280
 281    when (notNull (filter isRTSWay (wayNames dflags))
 282          && isInterpretiveMode mode) $
 283         hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
 284
 285         -- -prof and --interactive are not a good combination
 286    when (notNull (filter (not . isRTSWay) (wayNames dflags))
 287          && isInterpretiveMode mode) $
 288       do ghcError (UsageError
 289                    "--interactive can't be used with -prof or -unreg.")
 290         -- -ohi sanity check
 291    if (isJust (outputHi dflags) &&
 292       (isCompManagerMode mode || srcs `lengthExceeds` 1))
 293         then ghcError (UsageError "-ohi can only be used when compiling a single source file")
 294         else do
 295
 296         -- -o sanity checking
 297    if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
 298          && not (isLinkMode mode))
 299         then ghcError (UsageError "can't apply -o to multiple source files")
 300         else do
 301
 302    let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
 303
 304    when (not_linking && not (null objs)) $
 305         hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
 306
 307         -- Check that there are some input files
 308         -- (except in the interactive case)
 309    if null srcs && (null objs || not_linking) && needsInputsMode mode
 310         then ghcError (UsageError "no input files")
 311         else do
 312
 313      -- Verify that output files point somewhere sensible.
 314    verifyOutputFiles dflags
 315
 316
 317 -- Compiler output options
 318
 319 -- called to verify that the output files & directories
 320 -- point somewhere valid.
 321 --
 322 -- The assumption is that the directory portion of these output
 323 -- options will have to exist by the time 'verifyOutputFiles'
 324 -- is invoked.
 325 --
 326 verifyOutputFiles :: DynFlags -> IO ()
 327 verifyOutputFiles dflags = do
 328   -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
 329   let ofile = outputFile dflags
 330   when (isJust ofile) $ do
 331      let fn = fromJust ofile
 332      flg <- doesDirNameExist fn
 333      when (not flg) (nonExistentDir "-o" fn)
 334   let ohi = outputHi dflags
 335   when (isJust ohi) $ do
 336      let hi = fromJust ohi
 337      flg <- doesDirNameExist hi
 338      when (not flg) (nonExistentDir "-ohi" hi)
 339  where
 340    nonExistentDir flg dir =
 341      ghcError (CmdLineError ("error: directory portion of " ++
 342                              show dir ++ " does not exist (used with " ++
 343                              show flg ++ " option.)"))
 344
 345 -----------------------------------------------------------------------------
 346 -- GHC modes of operation
 347
 348 type Mode = Either PreStartupMode PostStartupMode
 349 type PostStartupMode = Either PreLoadMode PostLoadMode
 350
 351 data PreStartupMode
 352   = ShowVersion             -- ghc -V/--version
 353   | ShowNumVersion          -- ghc --numeric-version
 354   | ShowSupportedExtensions -- ghc --supported-extensions
 355   | Print String            -- ghc --print-foo
 356
 357 showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
 358 showVersionMode             = mkPreStartupMode ShowVersion
 359 showNumVersionMode          = mkPreStartupMode ShowNumVersion
 360 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
 361
 362 mkPreStartupMode :: PreStartupMode -> Mode
 363 mkPreStartupMode = Left
 364
 365 isShowVersionMode :: Mode -> Bool
 366 isShowVersionMode (Left ShowVersion) = True
 367 isShowVersionMode _ = False
 368
 369 isShowNumVersionMode :: Mode -> Bool
 370 isShowNumVersionMode (Left ShowNumVersion) = True
 371 isShowNumVersionMode _ = False
 372
 373 data PreLoadMode
 374   = ShowGhcUsage                           -- ghc -?
 375   | ShowGhciUsage                          -- ghci -?
 376   | ShowInfo                               -- ghc --info
 377   | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
 378
 379 showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
 380 showGhcUsageMode = mkPreLoadMode ShowGhcUsage
 381 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
 382 showInfoMode = mkPreLoadMode ShowInfo
 383
 384 printSetting :: String -> Mode
 385 printSetting k = mkPreLoadMode (PrintWithDynFlags f)
 386     where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
 387                    $ lookup k (compilerInfo dflags)
 388
 389 mkPreLoadMode :: PreLoadMode -> Mode
 390 mkPreLoadMode = Right . Left
 391
 392 isShowGhcUsageMode :: Mode -> Bool
 393 isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
 394 isShowGhcUsageMode _ = False
 395
 396 isShowGhciUsageMode :: Mode -> Bool
 397 isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
 398 isShowGhciUsageMode _ = False
 399
 400 data PostLoadMode
 401   = ShowInterface FilePath  -- ghc --show-iface
 402   | DoMkDependHS            -- ghc -M
 403   | StopBefore Phase        -- ghc -E | -C | -S
 404                             -- StopBefore StopLn is the default
 405   | DoMake                  -- ghc --make
 406   | DoInteractive           -- ghc --interactive
 407   | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
 408   | DoAbiHash               -- ghc --abi-hash
 409
 410 doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
 411 doMkDependHSMode = mkPostLoadMode DoMkDependHS
 412 doMakeMode = mkPostLoadMode DoMake
 413 doInteractiveMode = mkPostLoadMode DoInteractive
 414 doAbiHashMode = mkPostLoadMode DoAbiHash
 415
 416 showInterfaceMode :: FilePath -> Mode
 417 showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
 418
 419 stopBeforeMode :: Phase -> Mode
 420 stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
 421
 422 doEvalMode :: String -> Mode
 423 doEvalMode str = mkPostLoadMode (DoEval [str])
 424
 425 mkPostLoadMode :: PostLoadMode -> Mode
 426 mkPostLoadMode = Right . Right
 427
 428 isDoInteractiveMode :: Mode -> Bool
 429 isDoInteractiveMode (Right (Right DoInteractive)) = True
 430 isDoInteractiveMode _ = False
 431
 432 isStopLnMode :: Mode -> Bool
 433 isStopLnMode (Right (Right (StopBefore StopLn))) = True
 434 isStopLnMode _ = False
 435
 436 isDoMakeMode :: Mode -> Bool
 437 isDoMakeMode (Right (Right DoMake)) = True
 438 isDoMakeMode _ = False
 439
 440 #ifdef GHCI
 441 isInteractiveMode :: PostLoadMode -> Bool
 442 isInteractiveMode DoInteractive = True
 443 isInteractiveMode _             = False
 444 #endif
 445
 446 -- isInterpretiveMode: byte-code compiler involved
 447 isInterpretiveMode :: PostLoadMode -> Bool
 448 isInterpretiveMode DoInteractive = True
 449 isInterpretiveMode (DoEval _)    = True
 450 isInterpretiveMode _             = False
 451
 452 needsInputsMode :: PostLoadMode -> Bool
 453 needsInputsMode DoMkDependHS    = True
 454 needsInputsMode (StopBefore _)  = True
 455 needsInputsMode DoMake          = True
 456 needsInputsMode _               = False
 457
 458 -- True if we are going to attempt to link in this mode.
 459 -- (we might not actually link, depending on the GhcLink flag)
 460 isLinkMode :: PostLoadMode -> Bool
 461 isLinkMode (StopBefore StopLn) = True
 462 isLinkMode DoMake              = True
 463 isLinkMode DoInteractive       = True
 464 isLinkMode (DoEval _)          = True
 465 isLinkMode _                   = False
 466
 467 isCompManagerMode :: PostLoadMode -> Bool
 468 isCompManagerMode DoMake        = True
 469 isCompManagerMode DoInteractive = True
 470 isCompManagerMode (DoEval _)    = True
 471 isCompManagerMode _             = False
 472
 473 -- -----------------------------------------------------------------------------
 474 -- Parsing the mode flag
 475
 476 parseModeFlags :: [Located String]
 477                -> IO (Mode,
 478                       [Located String],
 479                       [Located String])
 480 parseModeFlags args = do
 481   let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
 482           runCmdLine (processArgs mode_flags args)
 483                      (Nothing, [], [])
 484       mode = case mModeFlag of
 485              Nothing     -> doMakeMode
 486              Just (m, _) -> m
 487       errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
 488   when (not (null errs)) $ ghcError $ errorsToGhcException errs
 489   return (mode, flags' ++ leftover, warns)
 490
 491 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
 492   -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
 493   -- so we collect the new ones and return them.
 494
 495 mode_flags :: [Flag ModeM]
 496 mode_flags =
 497   [  ------- help / version ----------------------------------------------
 498     Flag "?"                     (PassFlag (setMode showGhcUsageMode))
 499   , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
 500   , Flag "V"                     (PassFlag (setMode showVersionMode))
 501   , Flag "-version"              (PassFlag (setMode showVersionMode))
 502   , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
 503   , Flag "-info"                 (PassFlag (setMode showInfoMode))
 504   , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
 505   , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
 506   ] ++
 507   [ Flag k'                     (PassFlag (setMode (printSetting k)))
 508   | k <- ["Project version",
 509           "Booter version",
 510           "Stage",
 511           "Build platform",
 512           "Host platform",
 513           "Target platform",
 514           "Have interpreter",
 515           "Object splitting supported",
 516           "Have native code generator",
 517           "Support SMP",
 518           "Unregisterised",
 519           "Tables next to code",
 520           "RTS ways",
 521           "Leading underscore",
 522           "Debug on",
 523           "LibDir",
 524           "Global Package DB",
 525           "C compiler flags",
 526           "Gcc Linker flags",
 527           "Ld Linker flags"],
 528     let k' = "-print-" ++ map (replaceSpace . toLower) k
 529         replaceSpace ' ' = '-'
 530         replaceSpace c   = c
 531   ] ++
 532       ------- interfaces ----------------------------------------------------
 533   [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
 534                                                "--show-iface"))
 535
 536       ------- primary modes ------------------------------------------------
 537   , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
 538                                             addFlag "-no-link" f))
 539   , Flag "M"            (PassFlag (setMode doMkDependHSMode))
 540   , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
 541   , Flag "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
 542                                             addFlag "-fvia-C" f))
 543   , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
 544   , Flag "-make"        (PassFlag (setMode doMakeMode))
 545   , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
 546   , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
 547   , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
 548   ]
 549
 550 setMode :: Mode -> String -> EwM ModeM ()
 551 setMode newMode newFlag = liftEwM $ do
 552     (mModeFlag, errs, flags') <- getCmdLineState
 553     let (modeFlag', errs') =
 554             case mModeFlag of
 555             Nothing -> ((newMode, newFlag), errs)
 556             Just (oldMode, oldFlag) ->
 557                 case (oldMode, newMode) of
 558                     -- -c/--make are allowed together, and mean --make -no-link
 559                     _ |  isStopLnMode oldMode && isDoMakeMode newMode
 560                       || isStopLnMode newMode && isDoMakeMode oldMode ->
 561                       ((doMakeMode, "--make"), [])
 562
 563                     -- If we have both --help and --interactive then we
 564                     -- want showGhciUsage
 565                     _ | isShowGhcUsageMode oldMode &&
 566                         isDoInteractiveMode newMode ->
 567                             ((showGhciUsageMode, oldFlag), [])
 568                       | isShowGhcUsageMode newMode &&
 569                         isDoInteractiveMode oldMode ->
 570                             ((showGhciUsageMode, newFlag), [])
 571                     -- Otherwise, --help/--version/--numeric-version always win
 572                       | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
 573                       | isDominantFlag newMode -> ((newMode, newFlag), [])
 574                     -- We need to accumulate eval flags like "-e foo -e bar"
 575                     (Right (Right (DoEval esOld)),
 576                      Right (Right (DoEval [eNew]))) ->
 577                         ((Right (Right (DoEval (eNew : esOld))), oldFlag),
 578                          errs)
 579                     -- Saying e.g. --interactive --interactive is OK
 580                     _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
 581                     -- Otherwise, complain
 582                     _ -> let err = flagMismatchErr oldFlag newFlag
 583                          in ((oldMode, oldFlag), err : errs)
 584     putCmdLineState (Just modeFlag', errs', flags')
 585   where isDominantFlag f = isShowGhcUsageMode   f ||
 586                            isShowGhciUsageMode  f ||
 587                            isShowVersionMode    f ||
 588                            isShowNumVersionMode f
 589
 590 flagMismatchErr :: String -> String -> String
 591 flagMismatchErr oldFlag newFlag
 592     = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"
 593
 594 addFlag :: String -> String -> EwM ModeM ()
 595 addFlag s flag = liftEwM $ do
 596   (m, e, flags') <- getCmdLineState
 597   putCmdLineState (m, e, mkGeneralLocated loc s : flags')
 598     where loc = "addFlag by " ++ flag ++ " on the commandline"
 599
 600 -- ----------------------------------------------------------------------------
 601 -- Run --make mode
 602
 603 doMake :: [(String,Maybe Phase)] -> Ghc ()
 604 doMake srcs  = do
 605     let (hs_srcs, non_hs_srcs) = partition haskellish srcs
 606
 607         haskellish (f,Nothing) =
 608           looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
 609         haskellish (_,Just phase) =
 610           phase `notElem` [As, Cc, Cobjc, CmmCpp, Cmm, StopLn]
 611
 612     hsc_env <- GHC.getSession
 613
 614     -- if we have no haskell sources from which to do a dependency
 615     -- analysis, then just do one-shot compilation and/or linking.
 616     -- This means that "ghc Foo.o Bar.o -o baz" links the program as
 617     -- we expect.
 618     if (null hs_srcs)
 619        then liftIO (oneShot hsc_env StopLn srcs)
 620        else do
 621
 622     o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
 623                  non_hs_srcs
 624     liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
 625
 626     targets <- mapM (uncurry GHC.guessTarget) hs_srcs
 627     GHC.setTargets targets
 628     ok_flag <- GHC.load LoadAllTargets
 629
 630     when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
 631     return ()
 632
 633
 634 -- ---------------------------------------------------------------------------
 635 -- --show-iface mode
 636
 637 doShowIface :: DynFlags -> FilePath -> IO ()
 638 doShowIface dflags file = do
 639   hsc_env <- newHscEnv dflags
 640   showIface hsc_env file
 641
 642 -- ---------------------------------------------------------------------------
 643 -- Various banners and verbosity output.
 644
 645 showBanner :: PostLoadMode -> DynFlags -> IO ()
 646 showBanner _postLoadMode dflags = do
 647    let verb = verbosity dflags
 648
 649 #ifdef GHCI
 650    -- Show the GHCi banner
 651    when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
 652 #endif
 653
 654    -- Display details of the configuration in verbose mode
 655    when (verb >= 2) $
 656     do hPutStr stderr "Glasgow Haskell Compiler, Version "
 657        hPutStr stderr cProjectVersion
 658        hPutStr stderr ", stage "
 659        hPutStr stderr cStage
 660        hPutStr stderr " booted by GHC version "
 661        hPutStrLn stderr cBooterVersion
 662
 663 -- We print out a Read-friendly string, but a prettier one than the
 664 -- Show instance gives us
 665 showInfo :: DynFlags -> IO ()
 666 showInfo dflags = do
 667         let sq x = " [" ++ x ++ "\n ]"
 668         putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
 669
 670 showSupportedExtensions :: IO ()
 671 showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
 672
 673 showVersion :: IO ()
 674 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
 675
 676 showGhcUsage :: DynFlags -> IO ()
 677 showGhcUsage = showUsage False
 678
 679 showGhciUsage :: DynFlags -> IO ()
 680 showGhciUsage = showUsage True
 681
 682 showUsage :: Bool -> DynFlags -> IO ()
 683 showUsage ghci dflags = do
 684   let usage_path = if ghci then ghciUsagePath dflags
 685                            else ghcUsagePath dflags
 686   usage <- readFile usage_path
 687   dump usage
 688   where
 689      dump ""          = return ()
 690      dump ('$':'$':s) = putStr progName >> dump s
 691      dump (c:s)       = putChar c >> dump s
 692
 693 dumpFinalStats :: DynFlags -> IO ()
 694 dumpFinalStats dflags =
 695   when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
 696
 697 dumpFastStringStats :: DynFlags -> IO ()
 698 dumpFastStringStats dflags = do
 699   buckets <- getFastStringTable
 700   let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
 701       msg = text "FastString stats:" $$
 702             nest 4 (vcat [text "size:           " <+> int (length buckets),
 703                           text "entries:        " <+> int entries,
 704                           text "longest chain:  " <+> int longest,
 705                           text "z-encoded:      " <+> (is_z `pcntOf` entries),
 706                           text "has z-encoding: " <+> (has_z `pcntOf` entries)
 707                          ])
 708         -- we usually get more "has z-encoding" than "z-encoded", because
 709         -- when we z-encode a string it might hash to the exact same string,
 710         -- which will is not counted as "z-encoded".  Only strings whose
 711         -- Z-encoding is different from the original string are counted in
 712         -- the "z-encoded" total.
 713   putMsg dflags msg
 714   where
 715    x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
 716
 717 countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)
 718 countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
 719 countFS entries longest is_z has_z (b:bs) =
 720   let
 721         len = length b
 722         longest' = max len longest
 723         entries' = entries + len
 724         is_zs = length (filter isZEncoded b)
 725         has_zs = length (filter hasZEncoding b)
 726   in
 727         countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs
 728
 729 -- -----------------------------------------------------------------------------
 730 -- ABI hash support
 731
 732 {-
 733         ghc --abi-hash Data.Foo System.Bar
 734
 735 Generates a combined hash of the ABI for modules Data.Foo and
 736 System.Bar.  The modules must already be compiled, and appropriate -i
 737 options may be necessary in order to find the .hi files.
 738
 739 This is used by Cabal for generating the InstalledPackageId for a
 740 package.  The InstalledPackageId must change when the visible ABI of
 741 the package chagnes, so during registration Cabal calls ghc --abi-hash
 742 to get a hash of the package's ABI.
 743 -}
 744
 745 abiHash :: [(String, Maybe Phase)] -> Ghc ()
 746 abiHash strs = do
 747   hsc_env <- getSession
 748   let dflags = hsc_dflags hsc_env
 749
 750   liftIO $ do
 751
 752   let find_it str = do
 753          let modname = mkModuleName str
 754          r <- findImportedModule hsc_env modname Nothing
 755          case r of
 756            Found _ m -> return m
 757            _error    -> ghcError $ CmdLineError $ showSDoc $
 758                           cannotFindInterface dflags modname r
 759
 760   mods <- mapM find_it (map fst strs)
 761
 762   let get_iface modl = loadUserInterface False (text "abiHash") modl
 763   ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
 764
 765   bh <- openBinMem (3*1024) -- just less than a block
 766   mapM_ (put_ bh . mi_mod_hash) ifaces
 767   f <- fingerprintBinMem bh
 768
 769   putStrLn (showSDoc (ppr f))
 770
 771 -- -----------------------------------------------------------------------------
 772 -- Util
 773
 774 unknownFlagsErr :: [String] -> a
 775 unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))