Main.hs 29.7 KB
Newer Older
1
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
2

3 4 5 6
-----------------------------------------------------------------------------
--
-- GHC Driver program
--
7
-- (c) The University of Glasgow 2005
8 9 10 11 12
--
-----------------------------------------------------------------------------

module Main (main) where

13 14
-- The official GHC API
import qualified GHC
dterei's avatar
dterei committed
15
import GHC              ( -- DynFlags(..), HscTarget(..),
16
                          -- GhcMode(..), GhcLink(..),
17
                          Ghc, GhcMonad(..),
dterei's avatar
dterei committed
18
                          LoadHowMuch(..) )
19
import CmdLineParser
20

21
-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
dterei's avatar
dterei committed
22
import LoadIface        ( showIface )
23
import HscMain          ( newHscEnv )
dterei's avatar
dterei committed
24 25
import DriverPipeline   ( oneShot, compileFile )
import DriverMkDepend   ( doMkDependHS )
26
#ifdef GHCI
27
import InteractiveUI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
28
#endif
29

30

31
-- Various other random stuff that we need
Ian Lynagh's avatar
Ian Lynagh committed
32
import Config
Ian Lynagh's avatar
Ian Lynagh committed
33
import Constants
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
34
import HscTypes
dterei's avatar
dterei committed
35 36 37
import Packages         ( dumpPackages )
import DriverPhases     ( Phase(..), isSourceFilename, anyHsc,
                          startPhase, isHaskellSrcFilename )
Thomas Schilling's avatar
Thomas Schilling committed
38
import BasicTypes       ( failed )
39
import StaticFlags
40
import StaticFlagParser
Ian Lynagh's avatar
Ian Lynagh committed
41
import DynFlags
42
import ErrUtils
Ian Lynagh's avatar
Ian Lynagh committed
43
import FastString
44
import Outputable
45
import SrcLoc
46
import Util
47
import Panic
48
import MonadUtils       ( liftIO )
49

50 51 52 53 54 55 56
-- Imports for --abi-hash
import LoadIface           ( loadUserInterface )
import Module              ( mkModuleName )
import Finder              ( findImportedModule, cannotFindInterface )
import TcRnMonad           ( initIfaceCheck )
import Binary              ( openBinMem, put_, fingerprintBinMem )

57
-- Standard Haskell libraries
Simon Marlow's avatar
Simon Marlow committed
58 59 60
import System.IO
import System.Environment
import System.Exit
Ian Lynagh's avatar
Ian Lynagh committed
61
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
62
import Control.Monad
63
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
64 65
import Data.List
import Data.Maybe
66

67 68 69 70 71 72 73
-----------------------------------------------------------------------------
-- ToDo:

-- time commands when run with -v
-- user ways
-- Win32 support: proper signal handling
-- reading the package configuration file is too slow
74
-- -K<size>
75 76

-----------------------------------------------------------------------------
77
-- GHC's command-line interface
78

Ian Lynagh's avatar
Ian Lynagh committed
79
main :: IO ()
80 81
main = do
   hSetBuffering stdout NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
82
   hSetBuffering stderr NoBuffering
Ian Lynagh's avatar
Ian Lynagh committed
83
   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
84 85
    -- 1. extract the -B flag from the args
    argv0 <- getArgs
86

87
    let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
88 89 90
        mbMinusB | null minusB_args = Nothing
                 | otherwise = Just (drop 2 (last minusB_args))

91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
    let argv1' = map (mkGeneralLocated "on the commandline") argv1
    (argv2, staticFlagWarnings) <- parseStaticFlags argv1'

    -- 2. Parse the "mode" flags (--make, --interactive etc.)
    (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2

    let flagWarnings = staticFlagWarnings ++ modeFlagWarnings

    -- If all we want to do is something like showing the version number
    -- then do it now, before we start a GHC session etc. This makes
    -- getting basic information much more resilient.

    -- In particular, if we wait until later before giving the version
    -- number then bootstrapping gets confused, as it tries to find out
    -- what version of GHC it's using before package.conf exists, so
    -- starting the session fails.
    case mode of
        Left preStartupMode ->
            do case preStartupMode of
110
                   ShowSupportedExtensions -> showSupportedExtensions
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
                   ShowVersion             -> showVersion
                   ShowNumVersion          -> putStrLn cProjectVersion
        Right postStartupMode ->
            -- start our GHC session
            GHC.runGhc mbMinusB $ do

            dflags <- GHC.getSessionDynFlags

            case postStartupMode of
                Left preLoadMode ->
                    liftIO $ do
                        case preLoadMode of
                            ShowInfo               -> showInfo dflags
                            ShowGhcUsage           -> showGhcUsage  dflags
                            ShowGhciUsage          -> showGhciUsage dflags
                            PrintWithDynFlags f    -> putStrLn (f dflags)
                Right postLoadMode ->
                    main' postLoadMode dflags argv3 flagWarnings

main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
      -> Ghc ()
main' postLoadMode dflags0 args flagWarnings = do
133 134 135 136 137 138
  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
  -- can be further adjusted on a module by module basis, using only
  -- the -fvia-C and -fasm flags.  If the default HscTarget is not
  -- HscC or HscAsm, -fvia-C and -fasm have no effect.
  let dflt_target = hscTarget dflags0
      (mode, lang, link)
139 140 141 142 143
         = case postLoadMode of
               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
               DoMake          -> (CompManager, dflt_target,    LinkBinary)
               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
Thomas Schilling's avatar
Thomas Schilling committed
151
                         hscOutName = panic "Main.main:hscOutName not set",
152 153 154 155
                         verbosity = case postLoadMode of
                                         DoEval _ -> 0
                                         _other   -> 1
                        }
156

157 158
      -- turn on -fimplicit-import-qualified for GHCi now, so that it
      -- can be overriden from the command-line
159 160
      -- XXX: this should really be in the interactive DynFlags, but
      -- we don't set that until later in interactiveUI
161 162
      dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled
               | DoEval _      <- postLoadMode = imp_qual_enabled
163
               | otherwise                 = dflags1
ian@well-typed.com's avatar
ian@well-typed.com committed
164
        where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified
165

Thomas Schilling's avatar
Thomas Schilling committed
166 167
        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
168
  (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
169

170
  GHC.prettyPrintGhcErrors dflags2 $ do
Ian Lynagh's avatar
Ian Lynagh committed
171

172
  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
173 174

  handleSourceError (\e -> do
175 176 177
       GHC.printException e
       liftIO $ exitWith (ExitFailure 1)) $ do
         liftIO $ handleFlagWarnings dflags2 flagWarnings'
178

Thomas Schilling's avatar
Thomas Schilling committed
179
        -- make sure we clean up after ourselves
Ian Lynagh's avatar
Ian Lynagh committed
180
  GHC.defaultCleanupHandler dflags2 $ do
181

182
  liftIO $ showBanner postLoadMode dflags2
183

184
  let
dterei's avatar
dterei committed
185
     -- To simplify the handling of filepaths, we normalise all filepaths right
sof's avatar
sof committed
186
     -- away - e.g., for win32 platforms, backslashes are converted
sof's avatar
sof committed
187
     -- into forward slashes.
188
    normal_fileish_paths = map (normalise . unLoc) fileish_args
189
    (srcs, objs)         = partition_args normal_fileish_paths [] []
190

191 192 193 194 195 196
    dflags2a = dflags2 { ldInputs = objs ++ ldInputs dflags2 }

  -- we've finished manipulating the DynFlags, update the session
  _ <- GHC.setSessionDynFlags dflags2a
  dflags3 <- GHC.getSessionDynFlags
  hsc_env <- GHC.getSession
197

Thomas Schilling's avatar
Thomas Schilling committed
198
        ---------------- Display configuration -----------
Ian Lynagh's avatar
Ian Lynagh committed
199
  when (verbosity dflags3 >= 4) $
Thomas Schilling's avatar
Thomas Schilling committed
200
        liftIO $ dumpPackages dflags3
201

Ian Lynagh's avatar
Ian Lynagh committed
202
  when (verbosity dflags3 >= 3) $ do
Thomas Schilling's avatar
Thomas Schilling committed
203
        liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
204

Thomas Schilling's avatar
Thomas Schilling committed
205
        ---------------- Final sanity checking -----------
206
  liftIO $ checkOptions postLoadMode dflags3 srcs objs
207

Ian Lynagh's avatar
Ian Lynagh committed
208
  ---------------- Do the business -----------
Thomas Schilling's avatar
Thomas Schilling committed
209
  handleSourceError (\e -> do
210
       GHC.printException e
211
       liftIO $ exitWith (ExitFailure 1)) $ do
212
    case postLoadMode of
Thomas Schilling's avatar
Thomas Schilling committed
213 214
       ShowInterface f        -> liftIO $ doShowIface dflags3 f
       DoMake                 -> doMake srcs
215 216
       DoMkDependHS           -> doMkDependHS (map fst srcs)
       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
217 218
       DoInteractive          -> ghciUI srcs Nothing
       DoEval exprs           -> ghciUI srcs $ Just $ reverse exprs
219
       DoAbiHash              -> abiHash srcs
Thomas Schilling's avatar
Thomas Schilling committed
220 221

  liftIO $ dumpFinalStats dflags3
222

223
ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
224
#ifndef GHCI
225
ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
226 227
#else
ghciUI     = interactiveUI defaultGhciSettings
228 229
#endif

230 231 232 233 234
-- -----------------------------------------------------------------------------
-- Splitting arguments into source files and object files.  This is where we
-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
-- file indicating the phase specified by the -x option in force, if any.

Ian Lynagh's avatar
Ian Lynagh committed
235 236
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
237 238
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
dterei's avatar
dterei committed
239 240 241 242 243 244
  | "none" <- suff      = partition_args args srcs objs
  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
        where phase = startPhase suff
              (slurp,rest) = break (== "-x") args
              these_srcs = zip slurp (repeat (Just phase))
245 246 247 248 249 250
partition_args (arg:args) srcs objs
  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
  | otherwise               = partition_args args srcs (arg:objs)

    {-
      We split out the object files (.o, .dll) and add them
251
      to ldInputs for use by the linker.
252 253 254

      The following things should be considered compilation manager inputs:

dterei's avatar
dterei committed
255
       - haskell source files (strings ending in .hs, .lhs or other
256 257 258 259
         haskellish extension),

       - module names (not forgetting hierarchical module names),

Simon Marlow's avatar
Simon Marlow committed
260 261 262 263
       - things beginning with '-' are flags that were not recognised by
         the flag parser, and we want them to generate errors later in
         checkOptions, so we class them as source files (#5921)

264 265 266 267 268 269
       - and finally we consider everything not containing a '.' to be
         a comp manager input, as shorthand for a .hs or .lhs filename.

      Everything else is considered to be a linker object, and passed
      straight through to the linker.
    -}
Ian Lynagh's avatar
Ian Lynagh committed
270
looks_like_an_input :: String -> Bool
dterei's avatar
dterei committed
271
looks_like_an_input m =  isSourceFilename m
dterei's avatar
dterei committed
272
                      || looksLikeModuleName m
Simon Marlow's avatar
Simon Marlow committed
273
                      || "-" `isPrefixOf` m
dterei's avatar
dterei committed
274
                      || '.' `notElem` m
275

276 277 278
-- -----------------------------------------------------------------------------
-- Option sanity checks

Thomas Schilling's avatar
Thomas Schilling committed
279 280 281
-- | Ensure sanity of options.
--
-- Throws 'UsageError' or 'CmdLineError' if not.
282
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
283
     -- Final sanity checking before kicking off a compilation (pipeline).
284
checkOptions mode dflags srcs objs = do
ross's avatar
ross committed
285
     -- Complain about any unknown flags
286
   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
ross's avatar
ross committed
287 288
   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)

289
   when (notNull (filter wayRTSOnly (ways dflags))
290
         && isInterpretiveMode mode) $
291
        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
292

dterei's avatar
dterei committed
293
        -- -prof and --interactive are not a good combination
294
   when ((filter (not . wayRTSOnly) (ways dflags) /= defaultWays (settings dflags))
295
         && isInterpretiveMode mode) $
296
      do throwGhcException (UsageError
297
                   "--interactive can't be used with -prof or -unreg.")
dterei's avatar
dterei committed
298
        -- -ohi sanity check
dterei's avatar
dterei committed
299
   if (isJust (outputHi dflags) &&
300
      (isCompManagerMode mode || srcs `lengthExceeds` 1))
301
        then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
dterei's avatar
dterei committed
302
        else do
303

dterei's avatar
dterei committed
304
        -- -o sanity checking
305
   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
dterei's avatar
dterei committed
306
         && not (isLinkMode mode))
307
        then throwGhcException (UsageError "can't apply -o to multiple source files")
dterei's avatar
dterei committed
308
        else do
309

310
   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
311 312 313 314

   when (not_linking && not (null objs)) $
        hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)

dterei's avatar
dterei committed
315 316
        -- Check that there are some input files
        -- (except in the interactive case)
317
   if null srcs && (null objs || not_linking) && needsInputsMode mode
318
        then throwGhcException (UsageError "no input files")
dterei's avatar
dterei committed
319
        else do
320 321

     -- Verify that output files point somewhere sensible.
322 323 324 325 326 327
   verifyOutputFiles dflags


-- Compiler output options

-- called to verify that the output files & directories
dterei's avatar
dterei committed
328
-- point somewhere valid.
329 330 331 332
--
-- The assumption is that the directory portion of these output
-- options will have to exist by the time 'verifyOutputFiles'
-- is invoked.
dterei's avatar
dterei committed
333
--
334 335
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles dflags = do
336
  -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
337 338 339 340 341 342 343 344 345 346 347
  let ofile = outputFile dflags
  when (isJust ofile) $ do
     let fn = fromJust ofile
     flg <- doesDirNameExist fn
     when (not flg) (nonExistentDir "-o" fn)
  let ohi = outputHi dflags
  when (isJust ohi) $ do
     let hi = fromJust ohi
     flg <- doesDirNameExist hi
     when (not flg) (nonExistentDir "-ohi" hi)
 where
dterei's avatar
dterei committed
348
   nonExistentDir flg dir =
349
     throwGhcException (CmdLineError ("error: directory portion of " ++
dterei's avatar
dterei committed
350
                             show dir ++ " does not exist (used with " ++
dterei's avatar
dterei committed
351
                             show flg ++ " option.)"))
352 353 354 355

-----------------------------------------------------------------------------
-- GHC modes of operation

356 357 358 359 360
type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode

data PreStartupMode
  = ShowVersion             -- ghc -V/--version
Ian Lynagh's avatar
Ian Lynagh committed
361
  | ShowNumVersion          -- ghc --numeric-version
362
  | ShowSupportedExtensions -- ghc --supported-extensions
363

364 365 366 367
showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
showVersionMode             = mkPreStartupMode ShowVersion
showNumVersionMode          = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390

mkPreStartupMode :: PreStartupMode -> Mode
mkPreStartupMode = Left

isShowVersionMode :: Mode -> Bool
isShowVersionMode (Left ShowVersion) = True
isShowVersionMode _ = False

isShowNumVersionMode :: Mode -> Bool
isShowNumVersionMode (Left ShowNumVersion) = True
isShowNumVersionMode _ = False

data PreLoadMode
  = ShowGhcUsage                           -- ghc -?
  | ShowGhciUsage                          -- ghci -?
  | ShowInfo                               -- ghc --info
  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo

showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
showGhcUsageMode = mkPreLoadMode ShowGhcUsage
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
showInfoMode = mkPreLoadMode ShowInfo

391 392 393 394
printSetting :: String -> Mode
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
                   $ lookup k (compilerInfo dflags)
395 396 397 398 399 400 401 402 403 404 405

mkPreLoadMode :: PreLoadMode -> Mode
mkPreLoadMode = Right . Left

isShowGhcUsageMode :: Mode -> Bool
isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
isShowGhcUsageMode _ = False

isShowGhciUsageMode :: Mode -> Bool
isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
isShowGhciUsageMode _ = False
406

407 408
data PostLoadMode
  = ShowInterface FilePath  -- ghc --show-iface
Ian Lynagh's avatar
Ian Lynagh committed
409 410 411 412 413
  | DoMkDependHS            -- ghc -M
  | StopBefore Phase        -- ghc -E | -C | -S
                            -- StopBefore StopLn is the default
  | DoMake                  -- ghc --make
  | DoInteractive           -- ghc --interactive
Ian Lynagh's avatar
Ian Lynagh committed
414
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
415
  | DoAbiHash               -- ghc --abi-hash
416

Simon Marlow's avatar
Simon Marlow committed
417
doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
418 419 420
doMkDependHSMode = mkPostLoadMode DoMkDependHS
doMakeMode = mkPostLoadMode DoMake
doInteractiveMode = mkPostLoadMode DoInteractive
421
doAbiHashMode = mkPostLoadMode DoAbiHash
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437

showInterfaceMode :: FilePath -> Mode
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)

stopBeforeMode :: Phase -> Mode
stopBeforeMode phase = mkPostLoadMode (StopBefore phase)

doEvalMode :: String -> Mode
doEvalMode str = mkPostLoadMode (DoEval [str])

mkPostLoadMode :: PostLoadMode -> Mode
mkPostLoadMode = Right . Right

isDoInteractiveMode :: Mode -> Bool
isDoInteractiveMode (Right (Right DoInteractive)) = True
isDoInteractiveMode _ = False
438

439 440 441 442 443 444 445 446
isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopLn))) = True
isStopLnMode _ = False

isDoMakeMode :: Mode -> Bool
isDoMakeMode (Right (Right DoMake)) = True
isDoMakeMode _ = False

Ian Lynagh's avatar
Ian Lynagh committed
447
#ifdef GHCI
448
isInteractiveMode :: PostLoadMode -> Bool
449
isInteractiveMode DoInteractive = True
dterei's avatar
dterei committed
450
isInteractiveMode _             = False
Ian Lynagh's avatar
Ian Lynagh committed
451
#endif
452 453

-- isInterpretiveMode: byte-code compiler involved
454
isInterpretiveMode :: PostLoadMode -> Bool
455 456 457 458
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _)    = True
isInterpretiveMode _             = False

459
needsInputsMode :: PostLoadMode -> Bool
dterei's avatar
dterei committed
460 461 462 463
needsInputsMode DoMkDependHS    = True
needsInputsMode (StopBefore _)  = True
needsInputsMode DoMake          = True
needsInputsMode _               = False
464

465 466
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
467
isLinkMode :: PostLoadMode -> Bool
468
isLinkMode (StopBefore StopLn) = True
dterei's avatar
dterei committed
469
isLinkMode DoMake              = True
470 471
isLinkMode DoInteractive       = True
isLinkMode (DoEval _)          = True
dterei's avatar
dterei committed
472
isLinkMode _                   = False
473

474
isCompManagerMode :: PostLoadMode -> Bool
475 476 477 478 479 480 481 482
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _)    = True
isCompManagerMode _             = False

-- -----------------------------------------------------------------------------
-- Parsing the mode flag

483
parseModeFlags :: [Located String]
484
               -> IO (Mode,
485 486
                      [Located String],
                      [Located String])
487
parseModeFlags args = do
488
  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
489
          runCmdLine (processArgs mode_flags args)
490 491
                     (Nothing, [], [])
      mode = case mModeFlag of
492
             Nothing     -> doMakeMode
493 494
             Just (m, _) -> m
      errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
495
  when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
496
  return (mode, flags' ++ leftover, warns)
497

498
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
499 500 501
  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
  -- so we collect the new ones and return them.

502
mode_flags :: [Flag ModeM]
503 504
mode_flags =
  [  ------- help / version ----------------------------------------------
505 506 507 508 509 510 511 512
    Flag "?"                     (PassFlag (setMode showGhcUsageMode))
  , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
  , Flag "V"                     (PassFlag (setMode showVersionMode))
  , Flag "-version"              (PassFlag (setMode showVersionMode))
  , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
  , Flag "-info"                 (PassFlag (setMode showInfoMode))
  , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
  , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
513
  ] ++
514
  [ Flag k'                      (PassFlag (setMode (printSetting k)))
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
  | k <- ["Project version",
          "Booter version",
          "Stage",
          "Build platform",
          "Host platform",
          "Target platform",
          "Have interpreter",
          "Object splitting supported",
          "Have native code generator",
          "Support SMP",
          "Unregisterised",
          "Tables next to code",
          "RTS ways",
          "Leading underscore",
          "Debug on",
          "LibDir",
          "Global Package DB",
          "C compiler flags",
          "Gcc Linker flags",
          "Ld Linker flags"],
535 536 537 538
    let k' = "-print-" ++ map (replaceSpace . toLower) k
        replaceSpace ' ' = '-'
        replaceSpace c   = c
  ] ++
539
      ------- interfaces ----------------------------------------------------
540
  [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
541
                                               "--show-iface"))
542 543

      ------- primary modes ------------------------------------------------
544 545 546 547
  , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
                                            addFlag "-no-link" f))
  , Flag "M"            (PassFlag (setMode doMkDependHSMode))
  , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
548
  , Flag "C"            (PassFlag (setMode (stopBeforeMode HCc)))
549 550 551 552 553
  , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
  , Flag "-make"        (PassFlag (setMode doMakeMode))
  , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
  , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
  , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
554 555
  ]

556 557
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
558 559 560 561 562 563
    (mModeFlag, errs, flags') <- getCmdLineState
    let (modeFlag', errs') =
            case mModeFlag of
            Nothing -> ((newMode, newFlag), errs)
            Just (oldMode, oldFlag) ->
                case (oldMode, newMode) of
564 565 566 567 568
                    -- -c/--make are allowed together, and mean --make -no-link
                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
                      || isStopLnMode newMode && isDoMakeMode oldMode ->
                      ((doMakeMode, "--make"), [])

569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599
                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    _ | isShowGhcUsageMode oldMode &&
                        isDoInteractiveMode newMode ->
                            ((showGhciUsageMode, oldFlag), [])
                      | isShowGhcUsageMode newMode &&
                        isDoInteractiveMode oldMode ->
                            ((showGhciUsageMode, newFlag), [])
                    -- Otherwise, --help/--version/--numeric-version always win
                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
                      | isDominantFlag newMode -> ((newMode, newFlag), [])
                    -- We need to accumulate eval flags like "-e foo -e bar"
                    (Right (Right (DoEval esOld)),
                     Right (Right (DoEval [eNew]))) ->
                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),
                         errs)
                    -- Saying e.g. --interactive --interactive is OK
                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
                    -- Otherwise, complain
                    _ -> let err = flagMismatchErr oldFlag newFlag
                         in ((oldMode, oldFlag), err : errs)
    putCmdLineState (Just modeFlag', errs', flags')
  where isDominantFlag f = isShowGhcUsageMode   f ||
                           isShowGhciUsageMode  f ||
                           isShowVersionMode    f ||
                           isShowNumVersionMode f

flagMismatchErr :: String -> String -> String
flagMismatchErr oldFlag newFlag
    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"

600 601
addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
602 603 604
  (m, e, flags') <- getCmdLineState
  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
    where loc = "addFlag by " ++ flag ++ " on the commandline"
605

606 607 608
-- ----------------------------------------------------------------------------
-- Run --make mode

Thomas Schilling's avatar
Thomas Schilling committed
609 610
doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake srcs  = do
611 612
    let (hs_srcs, non_hs_srcs) = partition haskellish srcs

dterei's avatar
dterei committed
613 614 615 616
        haskellish (f,Nothing) =
          looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
        haskellish (_,Just phase) =
          phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
617

Thomas Schilling's avatar
Thomas Schilling committed
618
    hsc_env <- GHC.getSession
619 620 621 622 623 624

    -- if we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    if (null hs_srcs)
625
       then liftIO (oneShot hsc_env StopLn srcs)
626 627
       else do

628
    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
Thomas Schilling's avatar
Thomas Schilling committed
629
                 non_hs_srcs
630 631 632
    dflags <- GHC.getSessionDynFlags
    let dflags' = dflags { ldInputs = o_files ++ ldInputs dflags }
    _ <- GHC.setSessionDynFlags dflags'
633 634

    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
Thomas Schilling's avatar
Thomas Schilling committed
635 636 637 638
    GHC.setTargets targets
    ok_flag <- GHC.load LoadAllTargets

    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
639 640
    return ()

641 642 643 644 645 646

-- ---------------------------------------------------------------------------
-- --show-iface mode

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
647
  hsc_env <- newHscEnv dflags
648 649
  showIface hsc_env file

650 651
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
652

653 654
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner _postLoadMode dflags = do
655
   let verb = verbosity dflags
Ian Lynagh's avatar
Ian Lynagh committed
656

657 658
#ifdef GHCI
   -- Show the GHCi banner
659
   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
660 661
#endif

Ian Lynagh's avatar
Ian Lynagh committed
662 663 664 665
   -- Display details of the configuration in verbose mode
   when (verb >= 2) $
    do hPutStr stderr "Glasgow Haskell Compiler, Version "
       hPutStr stderr cProjectVersion
Ian Lynagh's avatar
Ian Lynagh committed
666
       hPutStr stderr ", stage "
Ian Lynagh's avatar
Ian Lynagh committed
667 668 669
       hPutStr stderr cStage
       hPutStr stderr " booted by GHC version "
       hPutStrLn stderr cBooterVersion
670

671 672
-- We print out a Read-friendly string, but a prettier one than the
-- Show instance gives us
673 674 675
showInfo :: DynFlags -> IO ()
showInfo dflags = do
        let sq x = " [" ++ x ++ "\n ]"
676
        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
677

678
showSupportedExtensions :: IO ()
679
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
Ian Lynagh's avatar
Ian Lynagh committed
680

681
showVersion :: IO ()
682 683 684 685 686 687 688 689 690 691 692 693
showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)

showGhcUsage :: DynFlags -> IO ()
showGhcUsage = showUsage False

showGhciUsage :: DynFlags -> IO ()
showGhciUsage = showUsage True

showUsage :: Bool -> DynFlags -> IO ()
showUsage ghci dflags = do
  let usage_path = if ghci then ghciUsagePath dflags
                           else ghcUsagePath dflags
694 695 696
  usage <- readFile usage_path
  dump usage
  where
697
     dump ""          = return ()
698
     dump ('$':'$':s) = putStr progName >> dump s
699
     dump (c:s)       = putChar c >> dump s
700

701
dumpFinalStats :: DynFlags -> IO ()
dterei's avatar
dterei committed
702
dumpFinalStats dflags =
ian@well-typed.com's avatar
ian@well-typed.com committed
703
  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
704 705 706 707

dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats dflags = do
  buckets <- getFastStringTable
Ian Lynagh's avatar
Ian Lynagh committed
708
  let (entries, longest, has_z) = countFS 0 0 0 buckets
709
      msg = text "FastString stats:" $$
dterei's avatar
dterei committed
710 711 712 713 714 715 716 717 718 719
            nest 4 (vcat [text "size:           " <+> int (length buckets),
                          text "entries:        " <+> int entries,
                          text "longest chain:  " <+> int longest,
                          text "has z-encoding: " <+> (has_z `pcntOf` entries)
                         ])
        -- we usually get more "has z-encoding" than "z-encoded", because
        -- when we z-encode a string it might hash to the exact same string,
        -- which will is not counted as "z-encoded".  Only strings whose
        -- Z-encoding is different from the original string are counted in
        -- the "z-encoded" total.
720 721 722
  putMsg dflags msg
  where
   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
Ian Lynagh's avatar
Ian Lynagh committed
723

Ian Lynagh's avatar
Ian Lynagh committed
724 725 726
countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
countFS entries longest has_z [] = (entries, longest, has_z)
countFS entries longest has_z (b:bs) =
727
  let
dterei's avatar
dterei committed
728 729 730 731
        len = length b
        longest' = max len longest
        entries' = entries + len
        has_zs = length (filter hasZEncoding b)
732
  in
Ian Lynagh's avatar
Ian Lynagh committed
733
        countFS entries' longest' (has_z + has_zs) bs
734

735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762
-- -----------------------------------------------------------------------------
-- ABI hash support

{-
        ghc --abi-hash Data.Foo System.Bar

Generates a combined hash of the ABI for modules Data.Foo and
System.Bar.  The modules must already be compiled, and appropriate -i
options may be necessary in order to find the .hi files.

This is used by Cabal for generating the InstalledPackageId for a
package.  The InstalledPackageId must change when the visible ABI of
the package chagnes, so during registration Cabal calls ghc --abi-hash
to get a hash of the package's ABI.
-}

abiHash :: [(String, Maybe Phase)] -> Ghc ()
abiHash strs = do
  hsc_env <- getSession
  let dflags = hsc_dflags hsc_env

  liftIO $ do

  let find_it str = do
         let modname = mkModuleName str
         r <- findImportedModule hsc_env modname Nothing
         case r of
           Found _ m -> return m
763
           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
764 765 766 767
                          cannotFindInterface dflags modname r

  mods <- mapM find_it (map fst strs)

Simon Marlow's avatar
Simon Marlow committed
768
  let get_iface modl = loadUserInterface False (text "abiHash") modl
769 770 771
  ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods

  bh <- openBinMem (3*1024) -- just less than a block
Ian Lynagh's avatar
Ian Lynagh committed
772
  put_ bh hiVersion
773 774
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
775 776 777
  mapM_ (put_ bh . mi_mod_hash) ifaces
  f <- fingerprintBinMem bh

Ian Lynagh's avatar
Ian Lynagh committed
778
  putStrLn (showPpr dflags f)
779

780 781 782 783
-- -----------------------------------------------------------------------------
-- Util

unknownFlagsErr :: [String] -> a
784
unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
785 786 787 788 789 790
  where
    oneError f =
        "unrecognised flag: " ++ f ++ "\n" ++
        (case fuzzyMatch f (nub allFlags) of
            [] -> ""
            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))