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