Main.hs 32.3 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation #-}
2
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
3

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

module Main (main) where

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

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

31

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

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
78
main :: IO ()
79
main = do
Austin Seipp's avatar
Austin Seipp committed
80
   initGCStatistics -- See Note [-Bsymbolic and hooks]
parcs's avatar
parcs committed
81 82
   hSetBuffering stdout LineBuffering
   hSetBuffering stderr LineBuffering
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
                   ShowVersion             -> showVersion
                   ShowNumVersion          -> putStrLn cProjectVersion
113
                   ShowOptions             -> showOptions
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
        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
134 135 136 137 138 139
  -- 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)
140 141 142 143 144
         = case postLoadMode of
               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
               DoMake          -> (CompManager, dflt_target,    LinkBinary)
               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
145
               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
146
               _               -> (OneShot,     dflt_target,    LinkBinary)
147

148 149
  let dflags1 = case lang of
                HscInterpreted ->
150 151 152 153 154 155 156 157 158
                    let platform = targetPlatform dflags0
                        dflags0a = updateWays $ dflags0 { ways = interpWays }
                        dflags0b = foldl gopt_set dflags0a
                                 $ concatMap (wayGeneralFlags platform)
                                             interpWays
                        dflags0c = foldl gopt_unset dflags0b
                                 $ concatMap (wayUnsetGeneralFlags platform)
                                             interpWays
                    in dflags0c
159 160 161
                _ ->
                    dflags0
      dflags2 = dflags1{ ghcMode   = mode,
162
                         hscTarget = lang,
163
                         ghcLink   = link,
164 165 166 167
                         verbosity = case postLoadMode of
                                         DoEval _ -> 0
                                         _other   -> 1
                        }
168

169 170
      -- turn on -fimplicit-import-qualified for GHCi now, so that it
      -- can be overriden from the command-line
171 172
      -- XXX: this should really be in the interactive DynFlags, but
      -- we don't set that until later in interactiveUI
173
      dflags3  | DoInteractive <- postLoadMode = imp_qual_enabled
174
               | DoEval _      <- postLoadMode = imp_qual_enabled
175 176
               | otherwise                     = dflags2
        where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified
177

Thomas Schilling's avatar
Thomas Schilling committed
178 179
        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
180
  (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args
181

182
  GHC.prettyPrintGhcErrors dflags4 $ do
Ian Lynagh's avatar
Ian Lynagh committed
183

184
  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
185 186

  handleSourceError (\e -> do
187 188
       GHC.printException e
       liftIO $ exitWith (ExitFailure 1)) $ do
189
         liftIO $ handleFlagWarnings dflags4 flagWarnings'
190

Thomas Schilling's avatar
Thomas Schilling committed
191
        -- make sure we clean up after ourselves
192
  GHC.defaultCleanupHandler dflags4 $ do
193

194
  liftIO $ showBanner postLoadMode dflags4
195

196
  let
dterei's avatar
dterei committed
197
     -- To simplify the handling of filepaths, we normalise all filepaths right
sof's avatar
sof committed
198
     -- away - e.g., for win32 platforms, backslashes are converted
sof's avatar
sof committed
199
     -- into forward slashes.
200
    normal_fileish_paths = map (normalise . unLoc) fileish_args
201
    (srcs, objs)         = partition_args normal_fileish_paths [] []
202

203 204
    dflags5 = dflags4 { ldInputs = map (FileOption "") objs
                                   ++ ldInputs dflags4 }
205 206

  -- we've finished manipulating the DynFlags, update the session
207 208
  _ <- GHC.setSessionDynFlags dflags5
  dflags6 <- GHC.getSessionDynFlags
209
  hsc_env <- GHC.getSession
210

Thomas Schilling's avatar
Thomas Schilling committed
211
        ---------------- Display configuration -----------
212 213
  when (verbosity dflags6 >= 4) $
        liftIO $ dumpPackages dflags6
214

215
  when (verbosity dflags6 >= 3) $ do
Thomas Schilling's avatar
Thomas Schilling committed
216
        liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
217

Thomas Schilling's avatar
Thomas Schilling committed
218
        ---------------- Final sanity checking -----------
219
  liftIO $ checkOptions postLoadMode dflags6 srcs objs
220

Ian Lynagh's avatar
Ian Lynagh committed
221
  ---------------- Do the business -----------
Thomas Schilling's avatar
Thomas Schilling committed
222
  handleSourceError (\e -> do
223
       GHC.printException e
224
       liftIO $ exitWith (ExitFailure 1)) $ do
225
    case postLoadMode of
226
       ShowInterface f        -> liftIO $ doShowIface dflags6 f
Thomas Schilling's avatar
Thomas Schilling committed
227
       DoMake                 -> doMake srcs
228 229
       DoMkDependHS           -> doMkDependHS (map fst srcs)
       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
230 231
       DoInteractive          -> ghciUI srcs Nothing
       DoEval exprs           -> ghciUI srcs $ Just $ reverse exprs
232
       DoAbiHash              -> abiHash srcs
Thomas Schilling's avatar
Thomas Schilling committed
233

234
  liftIO $ dumpFinalStats dflags6
235

236
ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
237
#ifndef GHCI
238
ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
239 240
#else
ghciUI     = interactiveUI defaultGhciSettings
241 242
#endif

243 244 245 246 247
-- -----------------------------------------------------------------------------
-- 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
248 249
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
250 251
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
dterei's avatar
dterei committed
252 253 254 255 256 257
  | "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))
258 259 260 261 262 263
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
264
      to ldInputs for use by the linker.
265 266 267

      The following things should be considered compilation manager inputs:

dterei's avatar
dterei committed
268
       - haskell source files (strings ending in .hs, .lhs or other
269 270 271 272
         haskellish extension),

       - module names (not forgetting hierarchical module names),

Simon Marlow's avatar
Simon Marlow committed
273 274 275 276
       - 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)

277 278 279 280 281 282
       - 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
283
looks_like_an_input :: String -> Bool
dterei's avatar
dterei committed
284
looks_like_an_input m =  isSourceFilename m
dterei's avatar
dterei committed
285
                      || looksLikeModuleName m
Simon Marlow's avatar
Simon Marlow committed
286
                      || "-" `isPrefixOf` m
dterei's avatar
dterei committed
287
                      || '.' `notElem` m
288

289 290 291
-- -----------------------------------------------------------------------------
-- Option sanity checks

Thomas Schilling's avatar
Thomas Schilling committed
292 293 294
-- | Ensure sanity of options.
--
-- Throws 'UsageError' or 'CmdLineError' if not.
295
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
296
     -- Final sanity checking before kicking off a compilation (pipeline).
297
checkOptions mode dflags srcs objs = do
ross's avatar
ross committed
298
     -- Complain about any unknown flags
299
   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
ross's avatar
ross committed
300 301
   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)

302
   when (notNull (filter wayRTSOnly (ways dflags))
303
         && isInterpretiveMode mode) $
304
        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
305

dterei's avatar
dterei committed
306
        -- -prof and --interactive are not a good combination
307
   when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
308
         && isInterpretiveMode mode) $
309
      do throwGhcException (UsageError
310
                   "--interactive can't be used with -prof or -unreg.")
dterei's avatar
dterei committed
311
        -- -ohi sanity check
dterei's avatar
dterei committed
312
   if (isJust (outputHi dflags) &&
313
      (isCompManagerMode mode || srcs `lengthExceeds` 1))
314
        then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
dterei's avatar
dterei committed
315
        else do
316

dterei's avatar
dterei committed
317
        -- -o sanity checking
318
   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
dterei's avatar
dterei committed
319
         && not (isLinkMode mode))
320
        then throwGhcException (UsageError "can't apply -o to multiple source files")
dterei's avatar
dterei committed
321
        else do
322

323
   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
324 325 326 327

   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
328 329
        -- Check that there are some input files
        -- (except in the interactive case)
330
   if null srcs && (null objs || not_linking) && needsInputsMode mode
331
        then throwGhcException (UsageError "no input files")
dterei's avatar
dterei committed
332
        else do
333 334

     -- Verify that output files point somewhere sensible.
335 336 337 338 339 340
   verifyOutputFiles dflags


-- Compiler output options

-- called to verify that the output files & directories
dterei's avatar
dterei committed
341
-- point somewhere valid.
342 343 344 345
--
-- 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
346
--
347 348
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles dflags = do
349
  -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
350 351 352 353 354 355 356 357 358 359 360
  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
361
   nonExistentDir flg dir =
362
     throwGhcException (CmdLineError ("error: directory portion of " ++
dterei's avatar
dterei committed
363
                             show dir ++ " does not exist (used with " ++
dterei's avatar
dterei committed
364
                             show flg ++ " option.)"))
365 366 367 368

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

369 370 371 372 373
type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode

data PreStartupMode
  = ShowVersion             -- ghc -V/--version
Ian Lynagh's avatar
Ian Lynagh committed
374
  | ShowNumVersion          -- ghc --numeric-version
375
  | ShowSupportedExtensions -- ghc --supported-extensions
376
  | ShowOptions             -- ghc --show-options
377

378
showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
379 380 381
showVersionMode             = mkPreStartupMode ShowVersion
showNumVersionMode          = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
382
showOptionsMode             = mkPreStartupMode ShowOptions
383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405

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

406 407 408 409
printSetting :: String -> Mode
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
                   $ lookup k (compilerInfo dflags)
410 411 412 413 414 415 416 417 418 419 420

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
421

422 423
data PostLoadMode
  = ShowInterface FilePath  -- ghc --show-iface
Ian Lynagh's avatar
Ian Lynagh committed
424 425 426 427 428
  | 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
429
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
430
  | DoAbiHash               -- ghc --abi-hash
431

Simon Marlow's avatar
Simon Marlow committed
432
doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
433 434 435
doMkDependHSMode = mkPostLoadMode DoMkDependHS
doMakeMode = mkPostLoadMode DoMake
doInteractiveMode = mkPostLoadMode DoInteractive
436
doAbiHashMode = mkPostLoadMode DoAbiHash
437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452

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
453

454 455 456 457 458 459 460 461
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
462
#ifdef GHCI
463
isInteractiveMode :: PostLoadMode -> Bool
464
isInteractiveMode DoInteractive = True
dterei's avatar
dterei committed
465
isInteractiveMode _             = False
Ian Lynagh's avatar
Ian Lynagh committed
466
#endif
467 468

-- isInterpretiveMode: byte-code compiler involved
469
isInterpretiveMode :: PostLoadMode -> Bool
470 471 472 473
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _)    = True
isInterpretiveMode _             = False

474
needsInputsMode :: PostLoadMode -> Bool
dterei's avatar
dterei committed
475 476 477 478
needsInputsMode DoMkDependHS    = True
needsInputsMode (StopBefore _)  = True
needsInputsMode DoMake          = True
needsInputsMode _               = False
479

480 481
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
482
isLinkMode :: PostLoadMode -> Bool
483
isLinkMode (StopBefore StopLn) = True
dterei's avatar
dterei committed
484
isLinkMode DoMake              = True
485 486
isLinkMode DoInteractive       = True
isLinkMode (DoEval _)          = True
dterei's avatar
dterei committed
487
isLinkMode _                   = False
488

489
isCompManagerMode :: PostLoadMode -> Bool
490 491 492 493 494 495 496 497
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _)    = True
isCompManagerMode _             = False

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

498
parseModeFlags :: [Located String]
499
               -> IO (Mode,
500 501
                      [Located String],
                      [Located String])
502
parseModeFlags args = do
503
  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
504
          runCmdLine (processArgs mode_flags args)
505 506
                     (Nothing, [], [])
      mode = case mModeFlag of
507
             Nothing     -> doMakeMode
508 509
             Just (m, _) -> m
      errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
510
  when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
511
  return (mode, flags' ++ leftover, warns)
512

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

517
mode_flags :: [Flag ModeM]
518 519
mode_flags =
  [  ------- help / version ----------------------------------------------
520 521 522 523 524 525
    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))
526
  , Flag "-show-options"         (PassFlag (setMode showOptionsMode))
527 528
  , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
  , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
529
  ] ++
530
  [ Flag k'                      (PassFlag (setMode (printSetting k)))
531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550
  | 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"],
551 552 553 554
    let k' = "-print-" ++ map (replaceSpace . toLower) k
        replaceSpace ' ' = '-'
        replaceSpace c   = c
  ] ++
555
      ------- interfaces ----------------------------------------------------
556
  [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
557
                                               "--show-iface"))
558 559

      ------- primary modes ------------------------------------------------
560 561 562 563
  , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
                                            addFlag "-no-link" f))
  , Flag "M"            (PassFlag (setMode doMkDependHSMode))
  , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
564
  , Flag "C"            (PassFlag (setMode (stopBeforeMode HCc)))
Simon Marlow's avatar
Simon Marlow committed
565
  , Flag "S"            (PassFlag (setMode (stopBeforeMode (As False))))
566 567 568 569
  , Flag "-make"        (PassFlag (setMode doMakeMode))
  , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
  , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
  , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
570 571
  ]

572 573
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
574 575 576 577 578 579
    (mModeFlag, errs, flags') <- getCmdLineState
    let (modeFlag', errs') =
            case mModeFlag of
            Nothing -> ((newMode, newFlag), errs)
            Just (oldMode, oldFlag) ->
                case (oldMode, newMode) of
580 581 582 583 584
                    -- -c/--make are allowed together, and mean --make -no-link
                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
                      || isStopLnMode newMode && isDoMakeMode oldMode ->
                      ((doMakeMode, "--make"), [])

585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615
                    -- 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 ++ "'"

616 617
addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
618 619 620
  (m, e, flags') <- getCmdLineState
  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
    where loc = "addFlag by " ++ flag ++ " on the commandline"
621

622 623 624
-- ----------------------------------------------------------------------------
-- Run --make mode

Thomas Schilling's avatar
Thomas Schilling committed
625 626
doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake srcs  = do
627 628
    let (hs_srcs, non_hs_srcs) = partition haskellish srcs

dterei's avatar
dterei committed
629
        haskellish (f,Nothing) =
630
          looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f
dterei's avatar
dterei committed
631
        haskellish (_,Just phase) =
Simon Marlow's avatar
Simon Marlow committed
632 633
          phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm
                          , StopLn]
634

Thomas Schilling's avatar
Thomas Schilling committed
635
    hsc_env <- GHC.getSession
636 637 638 639 640 641

    -- 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)
642
       then liftIO (oneShot hsc_env StopLn srcs)
643 644
       else do

645
    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
Thomas Schilling's avatar
Thomas Schilling committed
646
                 non_hs_srcs
647
    dflags <- GHC.getSessionDynFlags
648 649
    let dflags' = dflags { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags }
650
    _ <- GHC.setSessionDynFlags dflags'
651 652

    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
Thomas Schilling's avatar
Thomas Schilling committed
653 654 655 656
    GHC.setTargets targets
    ok_flag <- GHC.load LoadAllTargets

    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
657 658
    return ()

659 660 661 662 663 664

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

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
665
  hsc_env <- newHscEnv dflags
666 667
  showIface hsc_env file

668 669
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
670

671 672
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner _postLoadMode dflags = do
673
   let verb = verbosity dflags
Ian Lynagh's avatar
Ian Lynagh committed
674

675 676
#ifdef GHCI
   -- Show the GHCi banner
677
   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
678 679
#endif

Ian Lynagh's avatar
Ian Lynagh committed
680 681 682 683
   -- 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
684
       hPutStr stderr ", stage "
Ian Lynagh's avatar
Ian Lynagh committed
685 686 687
       hPutStr stderr cStage
       hPutStr stderr " booted by GHC version "
       hPutStrLn stderr cBooterVersion
688

689 690
-- We print out a Read-friendly string, but a prettier one than the
-- Show instance gives us
691 692 693
showInfo :: DynFlags -> IO ()
showInfo dflags = do
        let sq x = " [" ++ x ++ "\n ]"
694
        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
695

696
showSupportedExtensions :: IO ()
697
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
Ian Lynagh's avatar
Ian Lynagh committed
698

699
showVersion :: IO ()
700 701
showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)

702 703 704
showOptions :: IO ()
showOptions = putStr (unlines availableOptions)
    where
705
      availableOptions     = map ((:) '-') $
706 707 708 709 710 711 712 713 714 715 716
                             getFlagNames mode_flags   ++
                             getFlagNames flagsDynamic ++
                             (filterUnwantedStatic . getFlagNames $ flagsStatic) ++
                             flagsStaticNames
      getFlagNames opts         = map getFlagName opts
      getFlagName (Flag name _) = name
      -- this is a hack to get rid of two unwanted entries that get listed
      -- as static flags. Hopefully this hack will disappear one day together
      -- with static flags
      filterUnwantedStatic      = filter (\x -> not (x `elem` ["f", "fno-"]))

717 718 719 720 721 722 723 724 725 726
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
727 728 729
  usage <- readFile usage_path
  dump usage
  where
730
     dump ""          = return ()
731
     dump ('$':'$':s) = putStr progName >> dump s
732
     dump (c:s)       = putChar c >> dump s
733

734
dumpFinalStats :: DynFlags -> IO ()
dterei's avatar
dterei committed
735
dumpFinalStats dflags =
ian@well-typed.com's avatar
ian@well-typed.com committed
736
  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
737 738 739 740

dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats dflags = do
  buckets <- getFastStringTable
Ian Lynagh's avatar
Ian Lynagh committed
741
  let (entries, longest, has_z) = countFS 0 0 0 buckets
742
      msg = text "FastString stats:" $$
dterei's avatar
dterei committed
743 744 745 746 747 748 749 750 751 752
            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.
753 754 755
  putMsg dflags msg
  where
   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
Ian Lynagh's avatar
Ian Lynagh committed
756

Ian Lynagh's avatar
Ian Lynagh committed
757 758 759
countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
countFS entries longest has_z [] = (entries, longest, has_z)
countFS entries longest has_z (b:bs) =
760
  let
dterei's avatar
dterei committed
761 762 763 764
        len = length b
        longest' = max len longest
        entries' = entries + len
        has_zs = length (filter hasZEncoding b)
765
  in
Ian Lynagh's avatar
Ian Lynagh committed
766
        countFS entries' longest' (has_z + has_zs) bs
767

768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795
-- -----------------------------------------------------------------------------
-- 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
796
           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
797 798 799 800
                          cannotFindInterface dflags modname r

  mods <- mapM find_it (map fst strs)

Simon Marlow's avatar
Simon Marlow committed
801
  let get_iface modl = loadUserInterface False (text "abiHash") modl
802 803 804
  ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods

  bh <- openBinMem (3*1024) -- just less than a block
Ian Lynagh's avatar
Ian Lynagh committed
805
  put_ bh hiVersion
806 807
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
808 809 810
  mapM_ (put_ bh . mi_mod_hash) ifaces
  f <- fingerprintBinMem bh

Ian Lynagh's avatar
Ian Lynagh committed
811
  putStrLn (showPpr dflags f)
812

813 814 815 816
-- -----------------------------------------------------------------------------
-- Util

unknownFlagsErr :: [String] -> a
817
unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
818 819 820 821 822 823
  where
    oneError f =
        "unrecognised flag: " ++ f ++ "\n" ++
        (case fuzzyMatch f (nub allFlags) of
            [] -> ""
            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs)) 
Austin Seipp's avatar
Austin Seipp committed
824 825 826 827 828 829 830 831 832 833 834 835 836 837 838

{- Note [-Bsymbolic and hooks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Bsymbolic is a flag that prevents the binding of references to global
symbols to symbols outside the shared library being compiled (see `man
ld`). When dynamically linking, we don't use -Bsymbolic on the RTS
package: that is because we want hooks to be overridden by the user,
we don't want to constrain them to the RTS package.

Unfortunately this seems to have broken somehow on OS X: as a result,
defaultHooks (in hschooks.c) is not called, which does not initialize
the GC stats. As a result, this breaks things like `:set +s` in GHCi
(#8754). As a hacky workaround, we instead call 'defaultHooks'
directly to initalize the flags in the RTS.

Gabor Greif's avatar
Gabor Greif committed
839
A byproduct of this, I believe, is that hooks are likely broken on OS
Austin Seipp's avatar
Austin Seipp committed
840 841 842 843 844 845 846
X when dynamically linking. But this probably doesn't affect most
people since we're linking GHC dynamically, but most things themselves
link statically.
-}

foreign import ccall safe "initGCStatistics"
  initGCStatistics :: IO ()