Main.hs 38.7 KB
Newer Older
1 2 3 4
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
5
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
6

7 8 9 10
-----------------------------------------------------------------------------
--
-- GHC Driver program
--
11
-- (c) The University of Glasgow 2005
12 13 14 15 16
--
-----------------------------------------------------------------------------

module Main (main) where

17 18
-- The official GHC API
import qualified GHC
dterei's avatar
dterei committed
19
import GHC              ( -- DynFlags(..), HscTarget(..),
20
                          -- GhcMode(..), GhcLink(..),
21
                          Ghc, GhcMonad(..),
dterei's avatar
dterei committed
22
                          LoadHowMuch(..) )
Sylvain Henry's avatar
Sylvain Henry committed
23
import GHC.Driver.CmdLine
24

25
-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
Sylvain Henry's avatar
Sylvain Henry committed
26 27 28 29 30
import GHC.Iface.Load       ( showIface )
import GHC.Driver.Main      ( newHscEnv )
import GHC.Driver.Pipeline  ( oneShot, compileFile )
import GHC.Driver.MakeFile  ( doMkDependHS )
import GHC.Driver.Backpack  ( doBackpack )
31
import GHC.Driver.Ways
32
#if defined(HAVE_INTERNAL_INTERPRETER)
33
import GHCi.UI          ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
34
#endif
35

Edward Z. Yang's avatar
Edward Z. Yang committed
36
-- Frontend plugins
37
import GHC.Runtime.Loader   ( loadFrontendPlugin )
Sylvain Henry's avatar
Sylvain Henry committed
38
import GHC.Driver.Plugins
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
39
#if defined(HAVE_INTERNAL_INTERPRETER)
40
import GHC.Runtime.Loader   ( initializePlugins )
Ömer Sinan Ağacan's avatar
Ömer Sinan Ağacan committed
41
#endif
42
import GHC.Unit.Module     ( ModuleName, mkModuleName )
Edward Z. Yang's avatar
Edward Z. Yang committed
43

44

45
-- Various other random stuff that we need
46
import GHC.HandleEncoding
47 48
import GHC.Platform
import GHC.Platform.Host
49
import GHC.Settings.Config
Sylvain Henry's avatar
Sylvain Henry committed
50
import GHC.Settings.Constants
Sylvain Henry's avatar
Sylvain Henry committed
51
import GHC.Driver.Types
52
import GHC.Unit.State ( pprPackages, pprPackagesSimple )
Sylvain Henry's avatar
Sylvain Henry committed
53
import GHC.Driver.Phases
Sylvain Henry's avatar
Sylvain Henry committed
54
import GHC.Types.Basic     ( failed )
Sylvain Henry's avatar
Sylvain Henry committed
55
import GHC.Driver.Session hiding (WarnReason(..))
56 57 58
import GHC.Utils.Error
import GHC.Data.FastString
import GHC.Utils.Outputable as Outputable
Sylvain Henry's avatar
Sylvain Henry committed
59 60
import GHC.SysTools.BaseDir
import GHC.Settings.IO
Sylvain Henry's avatar
Sylvain Henry committed
61
import GHC.Types.SrcLoc
62 63
import GHC.Utils.Misc
import GHC.Utils.Panic
Sylvain Henry's avatar
Sylvain Henry committed
64
import GHC.Types.Unique.Supply
65
import GHC.Utils.Monad       ( liftIO )
66

67
-- Imports for --abi-hash
68 69 70 71 72
import GHC.Iface.Load          ( loadUserInterface )
import GHC.Driver.Finder       ( findImportedModule, cannotFindModule )
import GHC.Tc.Utils.Monad      ( initIfaceCheck )
import GHC.Utils.Binary        ( openBinMem, put_ )
import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
73

74
-- Standard Haskell libraries
Simon Marlow's avatar
Simon Marlow committed
75 76 77
import System.IO
import System.Environment
import System.Exit
Ian Lynagh's avatar
Ian Lynagh committed
78
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
79
import Control.Monad
80 81
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (throwE, runExceptT)
82
import Data.Char
83
import Data.List ( isPrefixOf, partition, intercalate )
Sylvain Henry's avatar
Sylvain Henry committed
84
import qualified Data.Set as Set
Simon Marlow's avatar
Simon Marlow committed
85
import Data.Maybe
86
import Prelude
87

88 89 90 91 92 93 94
-----------------------------------------------------------------------------
-- ToDo:

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

-----------------------------------------------------------------------------
98
-- GHC's command-line interface
99

Ian Lynagh's avatar
Ian Lynagh committed
100
main :: IO ()
101
main = do
Austin Seipp's avatar
Austin Seipp committed
102
   initGCStatistics -- See Note [-Bsymbolic and hooks]
parcs's avatar
parcs committed
103 104
   hSetBuffering stdout LineBuffering
   hSetBuffering stderr LineBuffering
105

106
   configureHandleEncoding
Ian Lynagh's avatar
Ian Lynagh committed
107
   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
108 109
    -- 1. extract the -B flag from the args
    argv0 <- getArgs
110

111
    let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
112 113 114
        mbMinusB | null minusB_args = Nothing
                 | otherwise = Just (drop 2 (last minusB_args))

Sylvain Henry's avatar
Sylvain Henry committed
115
    let argv2 = map (mkGeneralLocated "on the commandline") argv1
116 117

    -- 2. Parse the "mode" flags (--make, --interactive etc.)
Sylvain Henry's avatar
Sylvain Henry committed
118
    (mode, argv3, flagWarnings) <- parseModeFlags argv2
119 120 121 122 123 124 125 126 127 128 129 130

    -- 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
131
                   ShowSupportedExtensions   -> showSupportedExtensions mbMinusB
132 133 134
                   ShowVersion               -> showVersion
                   ShowNumVersion            -> putStrLn cProjectVersion
                   ShowOptions isInteractive -> showOptions isInteractive
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
        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

152
main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
153 154
      -> Ghc ()
main' postLoadMode dflags0 args flagWarnings = do
155 156 157 158 159 160
  -- 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)
161 162 163 164
         = case postLoadMode of
               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
               DoMake          -> (CompManager, dflt_target,    LinkBinary)
165
               DoBackpack      -> (CompManager, dflt_target,    LinkBinary)
166
               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
167
               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
168
               _               -> (OneShot,     dflt_target,    LinkBinary)
169

170
  let dflags1 = dflags0{ ghcMode   = mode,
171
                         hscTarget = lang,
172
                         ghcLink   = link,
173 174 175 176
                         verbosity = case postLoadMode of
                                         DoEval _ -> 0
                                         _other   -> 1
                        }
177

178
      -- turn on -fimplicit-import-qualified for GHCi now, so that it
179
      -- can be overridden from the command-line
180 181
      -- XXX: this should really be in the interactive DynFlags, but
      -- we don't set that until later in interactiveUI
182 183 184 185 186 187
      -- We also set -fignore-optim-changes and -fignore-hpc-changes,
      -- which are program-level options. Again, this doesn't really
      -- feel like the right place to handle this, but we don't have
      -- a great story for the moment.
      dflags2  | DoInteractive <- postLoadMode = def_ghci_flags
               | DoEval _      <- postLoadMode = def_ghci_flags
188
               | otherwise                     = dflags1
189 190 191
        where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified
                                       `gopt_set` Opt_IgnoreOptimChanges
                                       `gopt_set` Opt_IgnoreHpcChanges
192

193 194
        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
195 196 197 198 199 200
  (dflags3, fileish_args, dynamicFlagWarnings) <-
      GHC.parseDynamicFlags dflags2 args

  let dflags4 = case lang of
                HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
                    let platform = targetPlatform dflags3
201
                        dflags3a = updateWays $ dflags3 { ways = hostFullWays }
202 203
                        dflags3b = foldl gopt_set dflags3a
                                 $ concatMap (wayGeneralFlags platform)
204
                                             hostFullWays
205 206
                        dflags3c = foldl gopt_unset dflags3b
                                 $ concatMap (wayUnsetGeneralFlags platform)
207
                                             hostFullWays
208 209 210
                    in dflags3c
                _ ->
                    dflags3
211

212
  GHC.prettyPrintGhcErrors dflags4 $ do
Ian Lynagh's avatar
Ian Lynagh committed
213

214
  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
215 216

  handleSourceError (\e -> do
217 218
       GHC.printException e
       liftIO $ exitWith (ExitFailure 1)) $ do
219
         liftIO $ handleFlagWarnings dflags4 flagWarnings'
220

221
  liftIO $ showBanner postLoadMode dflags4
222

223
  let
dterei's avatar
dterei committed
224
     -- To simplify the handling of filepaths, we normalise all filepaths right
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
     -- away. Note the asymmetry of FilePath.normalise:
     --    Linux:   p/q -> p/q; p\q -> p\q
     --    Windows: p/q -> p\q; p\q -> p\q
     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
     -- to -foo.hs. We have to re-prepend the current directory.
    normalise_hyp fp
        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
        | otherwise                           = nfp
        where
#if defined(mingw32_HOST_OS)
          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
          strt_dot_sl = "./" `isPrefixOf` fp
#endif
          cur_dir = '.' : [pathSeparator]
          nfp = normalise fp
    normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args
242
    (srcs, objs)         = partition_args normal_fileish_paths [] []
243

244 245
    dflags5 = dflags4 { ldInputs = map (FileOption "") objs
                                   ++ ldInputs dflags4 }
246 247

  -- we've finished manipulating the DynFlags, update the session
248 249
  _ <- GHC.setSessionDynFlags dflags5
  dflags6 <- GHC.getSessionDynFlags
250
  hsc_env <- GHC.getSession
251

252
        ---------------- Display configuration -----------
253
  case verbosity dflags6 of
254
    v | v == 4 -> liftIO $ dumpPackagesSimple dflags6
255 256
      | v >= 5 -> liftIO $ dumpPackages dflags6
      | otherwise -> return ()
257

258
  liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)
259
        ---------------- Final sanity checking -----------
260
  liftIO $ checkOptions postLoadMode dflags6 srcs objs
261

262
  ---------------- Do the business -----------
263
  handleSourceError (\e -> do
264
       GHC.printException e
265
       liftIO $ exitWith (ExitFailure 1)) $ do
266
    case postLoadMode of
267
       ShowInterface f        -> liftIO $ doShowIface dflags6 f
268
       DoMake                 -> doMake srcs
269 270
       DoMkDependHS           -> doMkDependHS (map fst srcs)
       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
271 272 273
       DoInteractive          -> ghciUI hsc_env dflags6 srcs Nothing
       DoEval exprs           -> ghciUI hsc_env dflags6 srcs $ Just $
                                   reverse exprs
274
       DoAbiHash              -> abiHash (map fst srcs)
275
       ShowPackages           -> liftIO $ showPackages dflags6
Edward Z. Yang's avatar
Edward Z. Yang committed
276
       DoFrontend f           -> doFrontend f srcs
277
       DoBackpack             -> doBackpack (map fst srcs)
278

279
  liftIO $ dumpFinalStats dflags6
280

281 282
ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
       -> Ghc ()
283
#if !defined(HAVE_INTERNAL_INTERPRETER)
284 285
ghciUI _ _ _ _ =
  throwGhcException (CmdLineError "not built for interactive use")
286
#else
287 288 289 290
ghciUI hsc_env dflags0 srcs maybe_expr = do
  dflags1 <- liftIO (initializePlugins hsc_env dflags0)
  _ <- GHC.setSessionDynFlags dflags1
  interactiveUI defaultGhciSettings srcs maybe_expr
291 292
#endif

293 294 295 296 297
-- -----------------------------------------------------------------------------
-- 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
298 299
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
               -> ([(String, Maybe Phase)], [String])
300 301
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
dterei's avatar
dterei committed
302 303 304 305 306 307
  | "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))
308 309 310 311 312 313
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
314
      to ldInputs for use by the linker.
315 316 317

      The following things should be considered compilation manager inputs:

dterei's avatar
dterei committed
318
       - haskell source files (strings ending in .hs, .lhs or other
319 320 321 322
         haskellish extension),

       - module names (not forgetting hierarchical module names),

Simon Marlow's avatar
Simon Marlow committed
323 324 325 326
       - 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)

327
       - and finally we consider everything without an extension to be
328 329 330 331 332
         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
333
looks_like_an_input :: String -> Bool
dterei's avatar
dterei committed
334
looks_like_an_input m =  isSourceFilename m
dterei's avatar
dterei committed
335
                      || looksLikeModuleName m
Simon Marlow's avatar
Simon Marlow committed
336
                      || "-" `isPrefixOf` m
337
                      || not (hasExtension m)
338

339 340 341
-- -----------------------------------------------------------------------------
-- Option sanity checks

342 343 344
-- | Ensure sanity of options.
--
-- Throws 'UsageError' or 'CmdLineError' if not.
345
checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
346
     -- Final sanity checking before kicking off a compilation (pipeline).
347
checkOptions mode dflags srcs objs = do
348
     -- Complain about any unknown flags
349
   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
350 351
   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)

Sylvain Henry's avatar
Sylvain Henry committed
352
   when (not (Set.null (Set.filter wayRTSOnly (ways dflags)))
353
         && isInterpretiveMode mode) $
354
        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
355

dterei's avatar
dterei committed
356
        -- -prof and --interactive are not a good combination
Sylvain Henry's avatar
Sylvain Henry committed
357
   when ((Set.filter (not . wayRTSOnly) (ways dflags) /= hostFullWays)
358 359
         && isInterpretiveMode mode
         && not (gopt Opt_ExternalInterpreter dflags)) $
360
      do throwGhcException (UsageError
361
              "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
dterei's avatar
dterei committed
362
        -- -ohi sanity check
dterei's avatar
dterei committed
363
   if (isJust (outputHi dflags) &&
364
      (isCompManagerMode mode || srcs `lengthExceeds` 1))
365
        then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
dterei's avatar
dterei committed
366
        else do
367

dterei's avatar
dterei committed
368
        -- -o sanity checking
369
   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
dterei's avatar
dterei committed
370
         && not (isLinkMode mode))
371
        then throwGhcException (UsageError "can't apply -o to multiple source files")
dterei's avatar
dterei committed
372
        else do
373

374
   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
375 376 377 378

   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
379 380
        -- Check that there are some input files
        -- (except in the interactive case)
381
   if null srcs && (null objs || not_linking) && needsInputsMode mode
382
        then throwGhcException (UsageError "no input files")
dterei's avatar
dterei committed
383
        else do
384

385 386 387 388
   case mode of
      StopBefore HCc | hscTarget dflags /= HscC
        -> throwGhcException $ UsageError $
           "the option -C is only available with an unregisterised GHC"
389 390 391 392
      StopBefore (As False) | ghcLink dflags == NoLink
        -> throwGhcException $ UsageError $
           "the options -S and -fno-code are incompatible. Please omit -S"

393 394
      _ -> return ()

395
     -- Verify that output files point somewhere sensible.
396 397 398 399
   verifyOutputFiles dflags

-- Compiler output options

400
-- Called to verify that the output files point somewhere valid.
401 402 403 404
--
-- 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
405
--
406 407
-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
-- they don't exist, so don't check for those here (#2278).
408 409 410 411 412 413 414 415 416 417 418 419 420
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
421
   nonExistentDir flg dir =
422
     throwGhcException (CmdLineError ("error: directory portion of " ++
dterei's avatar
dterei committed
423
                             show dir ++ " does not exist (used with " ++
dterei's avatar
dterei committed
424
                             show flg ++ " option.)"))
425 426 427 428

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

429 430 431 432
type Mode = Either PreStartupMode PostStartupMode
type PostStartupMode = Either PreLoadMode PostLoadMode

data PreStartupMode
433 434 435 436
  = ShowVersion                          -- ghc -V/--version
  | ShowNumVersion                       -- ghc --numeric-version
  | ShowSupportedExtensions              -- ghc --supported-extensions
  | ShowOptions Bool {- isInteractive -} -- ghc --show-options
437

438
showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
439 440 441
showVersionMode             = mkPreStartupMode ShowVersion
showNumVersionMode          = mkPreStartupMode ShowNumVersion
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
442
showOptionsMode             = mkPreStartupMode (ShowOptions False)
443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465

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

466 467 468 469
printSetting :: String -> Mode
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
                   $ lookup k (compilerInfo dflags)
470 471 472 473 474 475 476 477 478 479 480

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
481

482 483
data PostLoadMode
  = ShowInterface FilePath  -- ghc --show-iface
Ian Lynagh's avatar
Ian Lynagh committed
484 485 486 487
  | DoMkDependHS            -- ghc -M
  | StopBefore Phase        -- ghc -E | -C | -S
                            -- StopBefore StopLn is the default
  | DoMake                  -- ghc --make
488
  | DoBackpack              -- ghc --backpack foo.bkp
Ian Lynagh's avatar
Ian Lynagh committed
489
  | DoInteractive           -- ghc --interactive
Ian Lynagh's avatar
Ian Lynagh committed
490
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
491
  | DoAbiHash               -- ghc --abi-hash
492
  | ShowPackages            -- ghc --show-packages
Edward Z. Yang's avatar
Edward Z. Yang committed
493
  | DoFrontend ModuleName   -- ghc --frontend Plugin.Module
494

495
doMkDependHSMode, doMakeMode, doInteractiveMode,
496
  doAbiHashMode, showPackagesMode :: Mode
497 498 499
doMkDependHSMode = mkPostLoadMode DoMkDependHS
doMakeMode = mkPostLoadMode DoMake
doInteractiveMode = mkPostLoadMode DoInteractive
500
doAbiHashMode = mkPostLoadMode DoAbiHash
501
showPackagesMode = mkPostLoadMode ShowPackages
502 503 504 505 506 507 508 509 510 511

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

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

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

Edward Z. Yang's avatar
Edward Z. Yang committed
512 513 514
doFrontendMode :: String -> Mode
doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))

515 516
doBackpackMode :: Mode
doBackpackMode = mkPostLoadMode DoBackpack
Edward Z. Yang's avatar
Edward Z. Yang committed
517

518 519 520 521 522 523
mkPostLoadMode :: PostLoadMode -> Mode
mkPostLoadMode = Right . Right

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

525 526 527 528 529 530 531 532
isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopLn))) = True
isStopLnMode _ = False

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

533 534 535 536
isDoEvalMode :: Mode -> Bool
isDoEvalMode (Right (Right (DoEval _))) = True
isDoEvalMode _ = False

537
#if defined(HAVE_INTERNAL_INTERPRETER)
538
isInteractiveMode :: PostLoadMode -> Bool
539
isInteractiveMode DoInteractive = True
dterei's avatar
dterei committed
540
isInteractiveMode _             = False
Ian Lynagh's avatar
Ian Lynagh committed
541
#endif
542 543

-- isInterpretiveMode: byte-code compiler involved
544
isInterpretiveMode :: PostLoadMode -> Bool
545 546 547 548
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _)    = True
isInterpretiveMode _             = False

549
needsInputsMode :: PostLoadMode -> Bool
dterei's avatar
dterei committed
550 551 552 553
needsInputsMode DoMkDependHS    = True
needsInputsMode (StopBefore _)  = True
needsInputsMode DoMake          = True
needsInputsMode _               = False
554

555 556
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
557
isLinkMode :: PostLoadMode -> Bool
558
isLinkMode (StopBefore StopLn) = True
dterei's avatar
dterei committed
559
isLinkMode DoMake              = True
560 561
isLinkMode DoInteractive       = True
isLinkMode (DoEval _)          = True
dterei's avatar
dterei committed
562
isLinkMode _                   = False
563

564
isCompManagerMode :: PostLoadMode -> Bool
565 566 567 568 569 570 571 572
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _)    = True
isCompManagerMode _             = False

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

573
parseModeFlags :: [Located String]
574
               -> IO (Mode,
575
                      [Located String],
576
                      [Warn])
577
parseModeFlags args = do
578
  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
579
          runCmdLine (processArgs mode_flags args)
580 581
                     (Nothing, [], [])
      mode = case mModeFlag of
582
             Nothing     -> doMakeMode
583
             Just (m, _) -> m
584 585 586

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

589
  return (mode, flags' ++ leftover, warns)
590

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

595
mode_flags :: [Flag ModeM]
596 597
mode_flags =
  [  ------- help / version ----------------------------------------------
598 599 600 601 602 603 604 605 606 607
    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))
608
  ] ++
609
  [ defFlag k'                      (PassFlag (setMode (printSetting k)))
610
  | k <- ["Project version",
611
          "Project Git commit id",
612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628
          "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",
629 630
          "C compiler link flags",
          "ld flags"],
631 632 633 634
    let k' = "-print-" ++ map (replaceSpace . toLower) k
        replaceSpace ' ' = '-'
        replaceSpace c   = c
  ] ++
635
      ------- interfaces ----------------------------------------------------
636
  [ defFlag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
637
                                               "--show-iface"))
638 639

      ------- primary modes ------------------------------------------------
640 641 642 643 644 645 646
  , 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))
647
  , defFlag "-backpack"    (PassFlag (setMode doBackpackMode))
648 649 650
  , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
  , defFlag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
  , defFlag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
Edward Z. Yang's avatar
Edward Z. Yang committed
651
  , defFlag "-frontend"    (SepArg   (\s -> setMode (doFrontendMode s) "-frontend"))
652 653
  ]

654 655
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
656 657 658 659 660 661
    (mModeFlag, errs, flags') <- getCmdLineState
    let (modeFlag', errs') =
            case mModeFlag of
            Nothing -> ((newMode, newFlag), errs)
            Just (oldMode, oldFlag) ->
                case (oldMode, newMode) of
662 663 664 665 666
                    -- -c/--make are allowed together, and mean --make -no-link
                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
                      || isStopLnMode newMode && isDoMakeMode oldMode ->
                      ((doMakeMode, "--make"), [])

667 668 669 670 671 672 673 674
                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    _ | isShowGhcUsageMode oldMode &&
                        isDoInteractiveMode newMode ->
                            ((showGhciUsageMode, oldFlag), [])
                      | isShowGhcUsageMode newMode &&
                        isDoInteractiveMode oldMode ->
                            ((showGhciUsageMode, newFlag), [])
675 676 677 678 679 680 681 682 683

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

684 685 686 687 688 689 690 691 692 693
                    -- 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)
694 695 696 697 698 699 700 701

                    -- --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)
702 703 704 705 706 707 708 709 710 711 712 713 714
                    -- 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 ++ "'"

715 716
addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
717 718 719
  (m, e, flags') <- getCmdLineState
  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
    where loc = "addFlag by " ++ flag ++ " on the commandline"
720

721 722 723
-- ----------------------------------------------------------------------------
-- Run --make mode

724 725
doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake srcs  = do
726
    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
727

728
    hsc_env <- GHC.getSession
729 730 731 732 733 734

    -- 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)
735
       then liftIO (oneShot hsc_env StopLn srcs)
736 737
       else do

738
    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
739
                 non_hs_srcs
740
    dflags <- GHC.getSessionDynFlags
741 742
    let dflags' = dflags { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags }
743
    _ <- GHC.setSessionDynFlags dflags'
744 745

    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
746 747 748 749
    GHC.setTargets targets
    ok_flag <- GHC.load LoadAllTargets

    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
750 751
    return ()

752 753 754 755 756 757

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

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
758
  hsc_env <- newHscEnv dflags
759 760
  showIface hsc_env file

761 762
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
763

764 765
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner _postLoadMode dflags = do
766
   let verb = verbosity dflags
Ian Lynagh's avatar
Ian Lynagh committed
767

768
#if defined(HAVE_INTERNAL_INTERPRETER)
769
   -- Show the GHCi banner
770
   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
771 772
#endif

Ian Lynagh's avatar
Ian Lynagh committed
773 774 775 776
   -- 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
777
       hPutStr stderr ", stage "
Ian Lynagh's avatar
Ian Lynagh committed
778 779 780
       hPutStr stderr cStage
       hPutStr stderr " booted by GHC version "
       hPutStrLn stderr cBooterVersion
781

782 783
-- We print out a Read-friendly string, but a prettier one than the
-- Show instance gives us
784 785 786
showInfo :: DynFlags -> IO ()
showInfo dflags = do
        let sq x = " [" ++ x ++ "\n ]"
787
        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
788

789
-- TODO use GHC.Utils.Error once that is disentangled from all the other GhcMonad stuff?
790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806
showSupportedExtensions :: Maybe String -> IO ()
showSupportedExtensions m_top_dir = do
  res <- runExceptT $ do
    top_dir <- lift (tryFindTopDir m_top_dir) >>= \case
      Nothing -> throwE $ SettingsError_MissingData "Could not find the top directory, missing -B flag"
      Just dir -> pure dir
    initSettings top_dir
  targetPlatformMini <- case res of
    Right s -> pure $ platformMini $ sTargetPlatform s
    Left (SettingsError_MissingData msg) -> do
      hPutStrLn stderr $ "WARNING: " ++ show msg
      hPutStrLn stderr $ "cannot know target platform so guessing target == host (native compiler)."
      pure cHostPlatformMini
    Left (SettingsError_BadData msg) -> do
      hPutStrLn stderr msg
      exitWith $ ExitFailure 1
  mapM_ putStrLn $ supportedLanguagesAndExtensions targetPlatformMini
Ian Lynagh's avatar
Ian Lynagh committed
807

808
showVersion :: IO ()
809 810
showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)

811 812
showOptions :: Bool -> IO ()
showOptions isInteractive = putStr (unlines availableOptions)
813
    where
814 815
      availableOptions = concat [
        flagsForCompletion isInteractive,
Sylvain Henry's avatar
Sylvain Henry committed
816
        map ('-':) (getFlagNames mode_flags)
817 818
        ]
      getFlagNames opts         = map flagName opts
819

820 821 822 823 824 825 826 827 828 829
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
830 831 832
  usage <- readFile usage_path
  dump usage
  where
833
     dump ""          = return ()
834
     dump ('$':'$':s) = putStr progName >> dump s
835
     dump (c:s)       = putChar c >> dump s
836

837
dumpFinalStats :: DynFlags -> IO ()
dterei's avatar
dterei committed
838
dumpFinalStats dflags =
ian@well-typed.com's avatar
ian@well-typed.com committed
839
  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
840 841 842

dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats dflags = do
843
  segments <- getFastStringTable
844
  hasZ <- getFastStringZEncCounter
845 846 847 848 849 850 851 852 853 854 855 856 857
  let buckets = concat segments
      bucketsPerSegment = map length segments
      entriesPerBucket = map length buckets
      entries = sum entriesPerBucket
      msg = text "FastString stats:" $$ nest 4 (vcat
        [ text "segments:         " <+> int (length segments)
        , text "buckets:          " <+> int (sum bucketsPerSegment)
        , text "entries:          " <+> int entries
        , text "largest segment:  " <+> int (maximum bucketsPerSegment)
        , text "smallest segment: " <+> int (minimum bucketsPerSegment)
        , text "longest bucket:   " <+> int (maximum entriesPerBucket)
        , text "has z-encoding:   " <+> (hasZ `pcntOf` entries)
        ])
dterei's avatar
dterei committed
858 859
        -- 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,
860
        -- which is not counted as "z-encoded".  Only strings whose
dterei's avatar
dterei committed
861 862
        -- Z-encoding is different from the original string are counted in
        -- the "z-encoded" total.
863 864
  putMsg dflags msg
  where
865
   x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
Ian Lynagh's avatar
Ian Lynagh committed
866

867
showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
Sylvain Henry's avatar
Sylvain Henry committed
868 869 870
showPackages       dflags = putStrLn (showSDoc dflags (pprPackages (pkgState dflags)))
dumpPackages       dflags = putMsg dflags (pprPackages (pkgState dflags))
dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple (pkgState dflags))
871

872
-- -----------------------------------------------------------------------------
Edward Z. Yang's avatar
Edward Z. Yang committed
873 874 875 876 877 878
-- Frontend plugin support

doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
doFrontend modname srcs = do
    hsc_env <- getSession
    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname
879 880
    frontend frontend_plugin
      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs
Edward Z. Yang's avatar
Edward Z. Yang committed
881 882

-- -----------------------------------------------------------------------------
883 884 885 886 887 888 889 890 891
-- 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.

892 893
This is used by Cabal for generating the ComponentId for a
package.  The ComponentId must change when the visible ABI of
894
the package changes, so during registration Cabal calls ghc --abi-hash
895 896 897
to get a hash of the package's ABI.
-}

898 899
-- | Print ABI hash of input modules.
--
900
-- The resulting hash is the MD5 of the GHC version used (#5328,
901 902 903 904
-- see 'hiVersion') and of the existing ABI hash from each module (see
-- 'mi_mod_hash').
abiHash :: [String] -- ^ List of module names
        -> Ghc ()
905 906 907 908 909 910 911 912 913 914
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
915
           Found _ m -> return m
916
           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
917
                          cannotFindModule dflags modname r
918

919
  mods <- mapM find_it strs
920

Simon Marlow's avatar
Simon Marlow committed
921
  let get_iface modl = loadUserInterface False (text "abiHash") modl
922
  ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods
923 924

  bh <- openBinMem (3*1024) -- just less than a block
Ian Lynagh's avatar
Ian Lynagh committed
925
  put_ bh hiVersion
926 927
    -- package hashes change when the compiler version changes (for now)
    -- see #5328
928
  mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces
929 930
  f <- fingerprintBinMem bh

Ian Lynagh's avatar
Ian Lynagh committed
931
  putStrLn (showPpr dflags f)
932

933 934 935 936
-- -----------------------------------------------------------------------------
-- Util

unknownFlagsErr :: [String] -> a
937
unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
938 939 940
  where
    oneError f =
        "unrecognised flag: " ++ f ++ "\n" ++
941
        (case match f (nubSort allNonDeprecatedFlags) of
942
            [] -> ""
943
            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))
944 945 946 947 948 949 950 951 952
    -- fixes #11789
    -- If the flag contains '=',
    -- this uses both the whole and the left side of '=' for comparing.
    match f allFlags
        | elem '=' f =
              let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags
                  fName = takeWhile (/= '=') f
              in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)
        | otherwise = fuzzyMatch f allFlags
Austin Seipp's avatar
Austin Seipp committed
953 954 955 956 957 958 959 960 961 962 963 964 965

{- 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'
966
directly to initialize the flags in the RTS.
Austin Seipp's avatar
Austin Seipp committed
967

Gabor Greif's avatar
Gabor Greif committed
968
A byproduct of this, I believe, is that hooks are likely broken on OS
Austin Seipp's avatar
Austin Seipp committed
969 970 971 972 973
X when dynamically linking. But this probably doesn't affect most
people since we're linking GHC dynamically, but most things themselves
link statically.
-}

974 975 976 977 978 979 980 981 982 983 984 985
-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then
-- running it causes an error like this:
--
-- Loading temp shared object failed:
-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics
--
-- Skipping the foreign call fixes this problem, and the outer GHCi
-- should have already made this call anyway.
#if defined(GHC_LOADED_INTO_GHCI)
initGCStatistics :: IO ()
initGCStatistics = return ()
#else
Austin Seipp's avatar
Austin Seipp committed
986 987
foreign import ccall safe "initGCStatistics"
  initGCStatistics :: IO ()
988
#endif