Main.hs 35.9 KB
Newer Older
1
{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
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 )
25
import DriverPipeline   ( oneShot, compileFile, mergeRequirement )
dterei's avatar
dterei committed
26
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
36
import Packages         ( pprPackages, pprPackagesSimple, pprModuleMap )
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 UniqSupply
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
main = do
Austin Seipp's avatar
Austin Seipp committed
81
   initGCStatistics -- See Note [-Bsymbolic and hooks]
parcs's avatar
parcs committed
82 83
   hSetBuffering stdout LineBuffering
   hSetBuffering stderr LineBuffering
84 85 86 87 88 89 90 91 92 93 94 95

   -- Handle GHC-specific character encoding flags, allowing us to control how
   -- GHC produces output regardless of OS.
   env <- getEnvironment
   case lookup "GHC_CHARENC" env of
    Just "UTF-8" -> do
     hSetEncoding stdout utf8
     hSetEncoding stderr utf8
    _ -> do
     -- Avoid GHC erroring out when trying to display unhandled characters
     hSetTranslit stdout
     hSetTranslit stderr
96

Ian Lynagh's avatar
Ian Lynagh committed
97
   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
98 99
    -- 1. extract the -B flag from the args
    argv0 <- getArgs
100

101
    let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
102 103 104
        mbMinusB | null minusB_args = Nothing
                 | otherwise = Just (drop 2 (last minusB_args))

105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
    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
124 125 126 127
                   ShowSupportedExtensions   -> showSupportedExtensions
                   ShowVersion               -> showVersion
                   ShowNumVersion            -> putStrLn cProjectVersion
                   ShowOptions isInteractive -> showOptions isInteractive
128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
        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
148 149 150 151 152 153
  -- 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)
154 155 156 157 158
         = case postLoadMode of
               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
               DoMake          -> (CompManager, dflt_target,    LinkBinary)
               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
159
               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
160
               DoMergeRequirements -> (OneShot, dflt_target,    LinkBinary)
161
               _               -> (OneShot,     dflt_target,    LinkBinary)
162

163 164
  let dflags1 = case lang of
                HscInterpreted ->
165 166 167 168 169 170 171 172 173
                    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
174 175 176
                _ ->
                    dflags0
      dflags2 = dflags1{ ghcMode   = mode,
177
                         hscTarget = lang,
178
                         ghcLink   = link,
179 180 181 182
                         verbosity = case postLoadMode of
                                         DoEval _ -> 0
                                         _other   -> 1
                        }
183

184 185
      -- turn on -fimplicit-import-qualified for GHCi now, so that it
      -- can be overriden from the command-line
186 187
      -- XXX: this should really be in the interactive DynFlags, but
      -- we don't set that until later in interactiveUI
188
      dflags3  | DoInteractive <- postLoadMode = imp_qual_enabled
189
               | DoEval _      <- postLoadMode = imp_qual_enabled
190 191
               | otherwise                     = dflags2
        where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified
192

Thomas Schilling's avatar
Thomas Schilling committed
193 194
        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
195
  (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args
196

197
  GHC.prettyPrintGhcErrors dflags4 $ do
Ian Lynagh's avatar
Ian Lynagh committed
198

199
  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
200 201

  handleSourceError (\e -> do
202 203
       GHC.printException e
       liftIO $ exitWith (ExitFailure 1)) $ do
204
         liftIO $ handleFlagWarnings dflags4 flagWarnings'
205

Thomas Schilling's avatar
Thomas Schilling committed
206
        -- make sure we clean up after ourselves
207
  GHC.defaultCleanupHandler dflags4 $ do
208

209
  liftIO $ showBanner postLoadMode dflags4
210

211
  let
dterei's avatar
dterei committed
212
     -- To simplify the handling of filepaths, we normalise all filepaths right
sof's avatar
sof committed
213
     -- away - e.g., for win32 platforms, backslashes are converted
sof's avatar
sof committed
214
     -- into forward slashes.
215
    normal_fileish_paths = map (normalise . unLoc) fileish_args
216
    (srcs, objs)         = partition_args normal_fileish_paths [] []
217

218 219
    dflags5 = dflags4 { ldInputs = map (FileOption "") objs
                                   ++ ldInputs dflags4 }
220 221

  -- we've finished manipulating the DynFlags, update the session
222 223
  _ <- GHC.setSessionDynFlags dflags5
  dflags6 <- GHC.getSessionDynFlags
224
  hsc_env <- GHC.getSession
225

Thomas Schilling's avatar
Thomas Schilling committed
226
        ---------------- Display configuration -----------
Edward Z. Yang's avatar
Edward Z. Yang committed
227
  case verbosity dflags6 of
228
    v | v == 4 -> liftIO $ dumpPackagesSimple dflags6
Edward Z. Yang's avatar
Edward Z. Yang committed
229 230
      | v >= 5 -> liftIO $ dumpPackages dflags6
      | otherwise -> return ()
231

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

235 236 237 238 239

  when (dopt Opt_D_dump_mod_map dflags6) . liftIO $
    printInfoForUser (dflags6 { pprCols = 200 })
                     (pkgQual dflags6) (pprModuleMap dflags6)

240
  liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)
Thomas Schilling's avatar
Thomas Schilling committed
241
        ---------------- Final sanity checking -----------
242
  liftIO $ checkOptions postLoadMode dflags6 srcs objs
243

Ian Lynagh's avatar
Ian Lynagh committed
244
  ---------------- Do the business -----------
Thomas Schilling's avatar
Thomas Schilling committed
245
  handleSourceError (\e -> do
246
       GHC.printException e
247
       liftIO $ exitWith (ExitFailure 1)) $ do
248
    case postLoadMode of
249
       ShowInterface f        -> liftIO $ doShowIface dflags6 f
Thomas Schilling's avatar
Thomas Schilling committed
250
       DoMake                 -> doMake srcs
251 252
       DoMkDependHS           -> doMkDependHS (map fst srcs)
       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
253 254
       DoInteractive          -> ghciUI srcs Nothing
       DoEval exprs           -> ghciUI srcs $ Just $ reverse exprs
255
       DoAbiHash              -> abiHash (map fst srcs)
256
       DoMergeRequirements           -> doMergeRequirements (map fst srcs)
257
       ShowPackages           -> liftIO $ showPackages dflags6
Thomas Schilling's avatar
Thomas Schilling committed
258

259
  liftIO $ dumpFinalStats dflags6
260

261
ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
262
#ifndef GHCI
263
ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
264 265
#else
ghciUI     = interactiveUI defaultGhciSettings
266 267
#endif

268 269 270 271 272
-- -----------------------------------------------------------------------------
-- 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
273 274
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
275 276
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
dterei's avatar
dterei committed
277 278 279 280 281 282
  | "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))
283 284 285 286 287 288
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
289
      to ldInputs for use by the linker.
290 291 292

      The following things should be considered compilation manager inputs:

dterei's avatar
dterei committed
293
       - haskell source files (strings ending in .hs, .lhs or other
294 295 296 297
         haskellish extension),

       - module names (not forgetting hierarchical module names),

Simon Marlow's avatar
Simon Marlow committed
298 299 300 301
       - 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)

302 303 304 305 306 307
       - 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
308
looks_like_an_input :: String -> Bool
dterei's avatar
dterei committed
309
looks_like_an_input m =  isSourceFilename m
dterei's avatar
dterei committed
310
                      || looksLikeModuleName m
Simon Marlow's avatar
Simon Marlow committed
311
                      || "-" `isPrefixOf` m
dterei's avatar
dterei committed
312
                      || '.' `notElem` m
313

314 315 316
-- -----------------------------------------------------------------------------
-- Option sanity checks

Thomas Schilling's avatar
Thomas Schilling committed
317 318 319
-- | Ensure sanity of options.
--
-- Throws 'UsageError' or 'CmdLineError' if not.
320
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
321
     -- Final sanity checking before kicking off a compilation (pipeline).
322
checkOptions mode dflags srcs objs = do
ross's avatar
ross committed
323
     -- Complain about any unknown flags
324
   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
ross's avatar
ross committed
325 326
   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)

327
   when (notNull (filter wayRTSOnly (ways dflags))
328
         && isInterpretiveMode mode) $
329
        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
330

dterei's avatar
dterei committed
331
        -- -prof and --interactive are not a good combination
332
   when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
333
         && isInterpretiveMode mode) $
334
      do throwGhcException (UsageError
335
                   "--interactive can't be used with -prof or -static.")
dterei's avatar
dterei committed
336
        -- -ohi sanity check
dterei's avatar
dterei committed
337
   if (isJust (outputHi dflags) &&
338
      (isCompManagerMode mode || srcs `lengthExceeds` 1))
339
        then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
dterei's avatar
dterei committed
340
        else do
341

dterei's avatar
dterei committed
342
        -- -o sanity checking
343
   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
dterei's avatar
dterei committed
344
         && not (isLinkMode mode))
345
        then throwGhcException (UsageError "can't apply -o to multiple source files")
dterei's avatar
dterei committed
346
        else do
347

348
   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
349 350 351 352

   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
353 354
        -- Check that there are some input files
        -- (except in the interactive case)
355
   if null srcs && (null objs || not_linking) && needsInputsMode mode
356
        then throwGhcException (UsageError "no input files")
dterei's avatar
dterei committed
357
        else do
358

359 360 361 362 363 364
   case mode of
      StopBefore HCc | hscTarget dflags /= HscC
        -> throwGhcException $ UsageError $
           "the option -C is only available with an unregisterised GHC"
      _ -> return ()

365
     -- Verify that output files point somewhere sensible.
366 367 368 369
   verifyOutputFiles dflags

-- Compiler output options

370
-- Called to verify that the output files point somewhere valid.
371 372 373 374
--
-- 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
375
--
376 377
-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
-- they don't exist, so don't check for those here (#2278).
378 379 380 381 382 383 384 385 386 387 388 389 390
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles dflags = do
  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
391
   nonExistentDir flg dir =
392
     throwGhcException (CmdLineError ("error: directory portion of " ++
dterei's avatar
dterei committed
393
                             show dir ++ " does not exist (used with " ++
dterei's avatar
dterei committed
394
                             show flg ++ " option.)"))
395 396 397 398

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

399 400 401 402
type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode

data PreStartupMode
403 404 405 406
  = ShowVersion                          -- ghc -V/--version
  | ShowNumVersion                       -- ghc --numeric-version
  | ShowSupportedExtensions              -- ghc --supported-extensions
  | ShowOptions Bool {- isInteractive -} -- ghc --show-options
407

408
showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
409 410 411
showVersionMode             = mkPreStartupMode ShowVersion
showNumVersionMode          = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
412
showOptionsMode             = mkPreStartupMode (ShowOptions False)
413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435

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

436 437 438 439
printSetting :: String -> Mode
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
                   $ lookup k (compilerInfo dflags)
440 441 442 443 444 445 446 447 448 449 450

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
451

452 453
data PostLoadMode
  = ShowInterface FilePath  -- ghc --show-iface
Ian Lynagh's avatar
Ian Lynagh committed
454 455 456 457 458
  | 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
459
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
460
  | DoAbiHash               -- ghc --abi-hash
461
  | ShowPackages            -- ghc --show-packages
462
  | DoMergeRequirements            -- ghc --merge-requirements
463

464
doMkDependHSMode, doMakeMode, doInteractiveMode,
465
  doAbiHashMode, showPackagesMode, doMergeRequirementsMode :: Mode
466 467 468
doMkDependHSMode = mkPostLoadMode DoMkDependHS
doMakeMode = mkPostLoadMode DoMake
doInteractiveMode = mkPostLoadMode DoInteractive
469
doAbiHashMode = mkPostLoadMode DoAbiHash
470
showPackagesMode = mkPostLoadMode ShowPackages
471
doMergeRequirementsMode = mkPostLoadMode DoMergeRequirements
472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487

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
488

489 490 491 492 493 494 495 496
isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopLn))) = True
isStopLnMode _ = False

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

497 498 499 500
isDoEvalMode :: Mode -> Bool
isDoEvalMode (Right (Right (DoEval _))) = True
isDoEvalMode _ = False

Ian Lynagh's avatar
Ian Lynagh committed
501
#ifdef GHCI
502
isInteractiveMode :: PostLoadMode -> Bool
503
isInteractiveMode DoInteractive = True
dterei's avatar
dterei committed
504
isInteractiveMode _             = False
Ian Lynagh's avatar
Ian Lynagh committed
505
#endif
506 507

-- isInterpretiveMode: byte-code compiler involved
508
isInterpretiveMode :: PostLoadMode -> Bool
509 510 511 512
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _)    = True
isInterpretiveMode _             = False

513
needsInputsMode :: PostLoadMode -> Bool
dterei's avatar
dterei committed
514 515 516 517
needsInputsMode DoMkDependHS    = True
needsInputsMode (StopBefore _)  = True
needsInputsMode DoMake          = True
needsInputsMode _               = False
518

519 520
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
521
isLinkMode :: PostLoadMode -> Bool
522
isLinkMode (StopBefore StopLn) = True
dterei's avatar
dterei committed
523
isLinkMode DoMake              = True
524 525
isLinkMode DoInteractive       = True
isLinkMode (DoEval _)          = True
dterei's avatar
dterei committed
526
isLinkMode _                   = False
527

528
isCompManagerMode :: PostLoadMode -> Bool
529 530 531 532 533 534 535 536
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _)    = True
isCompManagerMode _             = False

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

537
parseModeFlags :: [Located String]
538
               -> IO (Mode,
539 540
                      [Located String],
                      [Located String])
541
parseModeFlags args = do
542
  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
543
          runCmdLine (processArgs mode_flags args)
544 545
                     (Nothing, [], [])
      mode = case mModeFlag of
546
             Nothing     -> doMakeMode
547
             Just (m, _) -> m
548 549 550 551 552

  -- See Note [Handling errors when parsing commandline flags]
  unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
      map (("on the commandline", )) $ map unLoc errs1 ++ errs2

553
  return (mode, flags' ++ leftover, warns)
554

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

559
mode_flags :: [Flag ModeM]
560 561
mode_flags =
  [  ------- help / version ----------------------------------------------
562 563 564 565 566 567 568 569 570 571
    defFlag "?"                     (PassFlag (setMode showGhcUsageMode))
  , defFlag "-help"                 (PassFlag (setMode showGhcUsageMode))
  , defFlag "V"                     (PassFlag (setMode showVersionMode))
  , defFlag "-version"              (PassFlag (setMode showVersionMode))
  , defFlag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
  , defFlag "-info"                 (PassFlag (setMode showInfoMode))
  , defFlag "-show-options"         (PassFlag (setMode showOptionsMode))
  , defFlag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
  , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
  , defFlag "-show-packages"        (PassFlag (setMode showPackagesMode))
572
  ] ++
573
  [ defFlag k'                      (PassFlag (setMode (printSetting k)))
574
  | k <- ["Project version",
575
          "Project Git commit id",
576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594
          "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"],
595 596 597 598
    let k' = "-print-" ++ map (replaceSpace . toLower) k
        replaceSpace ' ' = '-'
        replaceSpace c   = c
  ] ++
599
      ------- interfaces ----------------------------------------------------
600
  [ defFlag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
601
                                               "--show-iface"))
602 603

      ------- primary modes ------------------------------------------------
604 605 606 607 608 609 610
  , defFlag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
                                               addFlag "-no-link" f))
  , defFlag "M"            (PassFlag (setMode doMkDependHSMode))
  , defFlag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
  , defFlag "C"            (PassFlag (setMode (stopBeforeMode HCc)))
  , defFlag "S"            (PassFlag (setMode (stopBeforeMode (As False))))
  , defFlag "-make"        (PassFlag (setMode doMakeMode))
611
  , defFlag "-merge-requirements" (PassFlag (setMode doMergeRequirementsMode))
612 613 614
  , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
  , defFlag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
  , defFlag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
615 616
  ]

617 618
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
619 620 621 622 623 624
    (mModeFlag, errs, flags') <- getCmdLineState
    let (modeFlag', errs') =
            case mModeFlag of
            Nothing -> ((newMode, newFlag), errs)
            Just (oldMode, oldFlag) ->
                case (oldMode, newMode) of
625 626 627 628 629
                    -- -c/--make are allowed together, and mean --make -no-link
                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
                      || isStopLnMode newMode && isDoMakeMode oldMode ->
                      ((doMakeMode, "--make"), [])

630 631 632 633 634 635 636 637
                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    _ | isShowGhcUsageMode oldMode &&
                        isDoInteractiveMode newMode ->
                            ((showGhciUsageMode, oldFlag), [])
                      | isShowGhcUsageMode newMode &&
                        isDoInteractiveMode oldMode ->
                            ((showGhciUsageMode, newFlag), [])
638 639 640 641 642 643 644 645 646

                    -- If we have both -e and --interactive then -e always wins
                    _ | isDoEvalMode oldMode &&
                        isDoInteractiveMode newMode ->
                            ((oldMode, oldFlag), [])
                      | isDoEvalMode newMode &&
                        isDoInteractiveMode oldMode ->
                            ((newMode, newFlag), [])

647 648 649 650 651 652 653 654 655 656
                    -- 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)
657 658 659 660 661 662 663 664

                    -- --interactive and --show-options are used together
                    (Right (Right DoInteractive), Left (ShowOptions _)) ->
                      ((Left (ShowOptions True),
                        "--interactive --show-options"), errs)
                    (Left (ShowOptions _), (Right (Right DoInteractive))) ->
                      ((Left (ShowOptions True),
                        "--show-options --interactive"), errs)
665 666 667 668 669 670 671 672 673 674 675 676 677
                    -- 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 ++ "'"

678 679
addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
680 681 682
  (m, e, flags') <- getCmdLineState
  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
    where loc = "addFlag by " ++ flag ++ " on the commandline"
683

684 685 686
-- ----------------------------------------------------------------------------
-- Run --make mode

Thomas Schilling's avatar
Thomas Schilling committed
687 688
doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake srcs  = do
689 690
    let (hs_srcs, non_hs_srcs) = partition haskellish srcs

dterei's avatar
dterei committed
691
        haskellish (f,Nothing) =
692
          looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
dterei's avatar
dterei committed
693
        haskellish (_,Just phase) =
thomie's avatar
thomie committed
694
          phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm
Simon Marlow's avatar
Simon Marlow committed
695
                          , StopLn]
696

Thomas Schilling's avatar
Thomas Schilling committed
697
    hsc_env <- GHC.getSession
698 699 700 701 702 703

    -- 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)
704
       then liftIO (oneShot hsc_env StopLn srcs)
705 706
       else do

707
    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
Thomas Schilling's avatar
Thomas Schilling committed
708
                 non_hs_srcs
709
    dflags <- GHC.getSessionDynFlags
710 711
    let dflags' = dflags { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags }
712
    _ <- GHC.setSessionDynFlags dflags'
713 714

    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
Thomas Schilling's avatar
Thomas Schilling committed
715 716 717 718
    GHC.setTargets targets
    ok_flag <- GHC.load LoadAllTargets

    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
719 720
    return ()

721 722 723 724 725 726 727 728 729 730
-- ----------------------------------------------------------------------------
-- Run --merge-requirements mode

doMergeRequirements :: [String] -> Ghc ()
doMergeRequirements srcs = mapM_ doMergeRequirement srcs

doMergeRequirement :: String -> Ghc ()
doMergeRequirement src = do
    hsc_env <- getSession
    liftIO $ mergeRequirement hsc_env (mkModuleName src)
731 732 733 734 735 736

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

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
737
  hsc_env <- newHscEnv dflags
738 739
  showIface hsc_env file

740 741
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
742

743 744
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner _postLoadMode dflags = do
745
   let verb = verbosity dflags
Ian Lynagh's avatar
Ian Lynagh committed
746

747 748
#ifdef GHCI
   -- Show the GHCi banner
749
   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
750 751
#endif

Ian Lynagh's avatar
Ian Lynagh committed
752 753 754 755
   -- 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
756
       hPutStr stderr ", stage "
Ian Lynagh's avatar
Ian Lynagh committed
757 758 759
       hPutStr stderr cStage
       hPutStr stderr " booted by GHC version "
       hPutStrLn stderr cBooterVersion
760

761 762
-- We print out a Read-friendly string, but a prettier one than the
-- Show instance gives us
763 764 765
showInfo :: DynFlags -> IO ()
showInfo dflags = do
        let sq x = " [" ++ x ++ "\n ]"
766
        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
767

768
showSupportedExtensions :: IO ()
769
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
Ian Lynagh's avatar
Ian Lynagh committed
770

771
showVersion :: IO ()
772 773
showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)

774 775
showOptions :: Bool -> IO ()
showOptions isInteractive = putStr (unlines availableOptions)
776
    where
777 778 779 780 781 782 783 784 785
      availableOptions = concat [
        flagsForCompletion isInteractive,
        map ('-':) (concat [
            getFlagNames mode_flags
          , (filterUnwantedStatic . getFlagNames $ flagsStatic)
          , flagsStaticNames
          ])
        ]
      getFlagNames opts         = map flagName opts
786 787 788
      -- 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
789
      filterUnwantedStatic      = filter (`notElem`["f", "fno-"])
790

791 792 793 794 795 796 797 798 799 800
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
801 802 803
  usage <- readFile usage_path
  dump usage
  where
804
     dump ""          = return ()
805
     dump ('$':'$':s) = putStr progName >> dump s
806
     dump (c:s)       = putChar c >> dump s
807

808
dumpFinalStats :: DynFlags -> IO ()
dterei's avatar
dterei committed
809
dumpFinalStats dflags =
ian@well-typed.com's avatar
ian@well-typed.com committed
810
  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
811 812 813 814

dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats dflags = do
  buckets <- getFastStringTable
Ian Lynagh's avatar
Ian Lynagh committed
815
  let (entries, longest, has_z) = countFS 0 0 0 buckets
816
      msg = text "FastString stats:" $$
dterei's avatar
dterei committed
817 818 819 820 821 822 823 824 825 826
            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.
827 828 829
  putMsg dflags msg
  where
   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
Ian Lynagh's avatar
Ian Lynagh committed
830

Ian Lynagh's avatar
Ian Lynagh committed
831 832 833
countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
countFS entries longest has_z [] = (entries, longest, has_z)
countFS entries longest has_z (b:bs) =
834
  let
dterei's avatar
dterei committed
835 836 837 838
        len = length b
        longest' = max len longest
        entries' = entries + len
        has_zs = length (filter hasZEncoding b)
839
  in
Ian Lynagh's avatar
Ian Lynagh committed
840
        countFS entries' longest' (has_z + has_zs) bs
841

842 843 844 845 846
showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
showPackages       dflags = putStrLn (showSDoc dflags (pprPackages dflags))
dumpPackages       dflags = putMsg dflags (pprPackages dflags)
dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)

847 848 849 850 851 852 853 854 855 856
-- -----------------------------------------------------------------------------
-- 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.

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

863 864 865 866 867 868 869
-- | Print ABI hash of input modules.
--
-- The resulting hash is the MD5 of the GHC version used (Trac #5328,
-- see 'hiVersion') and of the existing ABI hash from each module (see
-- 'mi_mod_hash').
abiHash :: [String] -- ^ List of module names
        -> Ghc ()
870 871 872 873 874 875 876 877 878 879
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
880
           Found _ m -> return m
881
           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
882 883
                          cannotFindInterface dflags modname r

884
  mods <- mapM find_it strs
885

Simon Marlow's avatar
Simon Marlow committed
886
  let get_iface modl = loadUserInterface False (text "abiHash") modl
887 888 889
  ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods

  bh <- openBinMem (3*1024) -- just less than a block
Ian Lynagh's avatar
Ian Lynagh committed
890
  put_ bh hiVersion
891 892
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
893 894 895
  mapM_ (put_ bh . mi_mod_hash) ifaces
  f <- fingerprintBinMem bh

Ian Lynagh's avatar
Ian Lynagh committed
896
  putStrLn (showPpr dflags f)
897

898 899 900 901
-- -----------------------------------------------------------------------------
-- Util

unknownFlagsErr :: [String] -> a
902
unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
903 904 905 906 907
  where
    oneError f =
        "unrecognised flag: " ++ f ++ "\n" ++
        (case fuzzyMatch f (nub allFlags) of
            [] -> ""
908
            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))
Austin Seipp's avatar
Austin Seipp committed
909 910 911 912 913 914 915 916 917 918 919 920 921 922 923

{- 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,