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 )
dterei's avatar
dterei committed
26
import DriverMkDepend   ( doMkDependHS )
Edward Z. Yang's avatar
Edward Z. Yang committed
27
import DriverBkp   ( doBackpack )
Ben Gamari's avatar
Ben Gamari committed
28
#if defined(GHCI)
29
import GHCi.UI          ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
30
#endif
31

Edward Z. Yang's avatar
Edward Z. Yang committed
32
-- Frontend plugins
Ben Gamari's avatar
Ben Gamari committed
33
#if defined(GHCI)
34
import DynamicLoading   ( loadFrontendPlugin )
Edward Z. Yang's avatar
Edward Z. Yang committed
35
import Plugins
36
37
#else
import DynamicLoading   ( pluginError )
Edward Z. Yang's avatar
Edward Z. Yang committed
38
39
40
#endif
import Module           ( ModuleName )

41

42
-- Various other random stuff that we need
Ian Lynagh's avatar
Ian Lynagh committed
43
import Config
Ian Lynagh's avatar
Ian Lynagh committed
44
import Constants
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
45
import HscTypes
Edward Z. Yang's avatar
Edward Z. Yang committed
46
import Packages         ( pprPackages, pprPackagesSimple )
47
import DriverPhases
Thomas Schilling's avatar
Thomas Schilling committed
48
import BasicTypes       ( failed )
Ian Lynagh's avatar
Ian Lynagh committed
49
import DynFlags
50
import ErrUtils
Ian Lynagh's avatar
Ian Lynagh committed
51
import FastString
52
import Outputable
53
import SrcLoc
54
import Util
55
import Panic
56
import UniqSupply
57
import MonadUtils       ( liftIO )
58

59
60
61
-- Imports for --abi-hash
import LoadIface           ( loadUserInterface )
import Module              ( mkModuleName )
62
import Finder              ( findImportedModule, cannotFindModule )
63
import TcRnMonad           ( initIfaceCheck )
64
65
import Binary              ( openBinMem, put_ )
import BinFingerprint      ( fingerprintBinMem )
66

67
-- Standard Haskell libraries
Simon Marlow's avatar
Simon Marlow committed
68
69
70
import System.IO
import System.Environment
import System.Exit
Ian Lynagh's avatar
Ian Lynagh committed
71
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
72
import Control.Monad
73
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
74
75
import Data.List
import Data.Maybe
76

77
78
79
80
81
82
83
-----------------------------------------------------------------------------
-- ToDo:

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

-----------------------------------------------------------------------------
87
-- GHC's command-line interface
88

Ian Lynagh's avatar
Ian Lynagh committed
89
main :: IO ()
90
main = do
Austin Seipp's avatar
Austin Seipp committed
91
   initGCStatistics -- See Note [-Bsymbolic and hooks]
parcs's avatar
parcs committed
92
93
   hSetBuffering stdout LineBuffering
   hSetBuffering stderr LineBuffering
94
95
96
97
98
99
100
101
102
103
104
105

   -- 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
106

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
132
133
134
                   ShowSupportedExtensions   -> showSupportedExtensions
                   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
152
153
154
        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
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
179
      -- turn on -fimplicit-import-qualified for GHCi now, so that it
      -- can be overriden 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
      dflags2  | DoInteractive <- postLoadMode = imp_qual_enabled
183
               | DoEval _      <- postLoadMode = imp_qual_enabled
184
185
               | otherwise                     = dflags1
        where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified
186

Thomas Schilling's avatar
Thomas Schilling committed
187
188
        -- The rest of the arguments are "dynamic"
        -- Leftover ones are presumably files
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
  (dflags3, fileish_args, dynamicFlagWarnings) <-
      GHC.parseDynamicFlags dflags2 args

  let dflags4 = case lang of
                HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
                    let platform = targetPlatform dflags3
                        dflags3a = updateWays $ dflags3 { ways = interpWays }
                        dflags3b = foldl gopt_set dflags3a
                                 $ concatMap (wayGeneralFlags platform)
                                             interpWays
                        dflags3c = foldl gopt_unset dflags3b
                                 $ concatMap (wayUnsetGeneralFlags platform)
                                             interpWays
                    in dflags3c
                _ ->
                    dflags3
205

206
  GHC.prettyPrintGhcErrors dflags4 $ do
Ian Lynagh's avatar
Ian Lynagh committed
207

208
  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
209
210

  handleSourceError (\e -> do
211
212
       GHC.printException e
       liftIO $ exitWith (ExitFailure 1)) $ do
213
         liftIO $ handleFlagWarnings dflags4 flagWarnings'
214

215
  liftIO $ showBanner postLoadMode dflags4
216

217
  let
dterei's avatar
dterei committed
218
     -- To simplify the handling of filepaths, we normalise all filepaths right
sof's avatar
sof committed
219
     -- away - e.g., for win32 platforms, backslashes are converted
sof's avatar
sof committed
220
     -- into forward slashes.
221
    normal_fileish_paths = map (normalise . unLoc) fileish_args
222
    (srcs, objs)         = partition_args normal_fileish_paths [] []
223

224
225
    dflags5 = dflags4 { ldInputs = map (FileOption "") objs
                                   ++ ldInputs dflags4 }
226
227

  -- we've finished manipulating the DynFlags, update the session
228
229
  _ <- GHC.setSessionDynFlags dflags5
  dflags6 <- GHC.getSessionDynFlags
230
  hsc_env <- GHC.getSession
231

Thomas Schilling's avatar
Thomas Schilling committed
232
        ---------------- Display configuration -----------
Edward Z. Yang's avatar
Edward Z. Yang committed
233
  case verbosity dflags6 of
234
    v | v == 4 -> liftIO $ dumpPackagesSimple dflags6
Edward Z. Yang's avatar
Edward Z. Yang committed
235
236
      | v >= 5 -> liftIO $ dumpPackages dflags6
      | otherwise -> return ()
237

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

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

258
  liftIO $ dumpFinalStats dflags6
259

260
ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
Ben Gamari's avatar
Ben Gamari committed
261
#if !defined(GHCI)
262
ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
263
264
#else
ghciUI     = interactiveUI defaultGhciSettings
265
266
#endif

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

      The following things should be considered compilation manager inputs:

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

       - module names (not forgetting hierarchical module names),

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

301
       - and finally we consider everything without an extension to be
302
303
304
305
306
         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
307
looks_like_an_input :: String -> Bool
dterei's avatar
dterei committed
308
looks_like_an_input m =  isSourceFilename m
dterei's avatar
dterei committed
309
                      || looksLikeModuleName m
Simon Marlow's avatar
Simon Marlow committed
310
                      || "-" `isPrefixOf` m
311
                      || not (hasExtension m)
312

313
314
315
-- -----------------------------------------------------------------------------
-- Option sanity checks

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

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

dterei's avatar
dterei committed
330
        -- -prof and --interactive are not a good combination
331
   when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
332
333
         && isInterpretiveMode mode
         && not (gopt Opt_ExternalInterpreter dflags)) $
334
      do throwGhcException (UsageError
335
              "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
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
  | DoMkDependHS            -- ghc -M
  | StopBefore Phase        -- ghc -E | -C | -S
                            -- StopBefore StopLn is the default
  | DoMake                  -- ghc --make
458
  | DoBackpack              -- ghc --backpack foo.bkp
Ian Lynagh's avatar
Ian Lynagh committed
459
  | DoInteractive           -- ghc --interactive
Ian Lynagh's avatar
Ian Lynagh committed
460
  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
461
  | DoAbiHash               -- ghc --abi-hash
462
  | ShowPackages            -- ghc --show-packages
Edward Z. Yang's avatar
Edward Z. Yang committed
463
  | DoFrontend ModuleName   -- ghc --frontend Plugin.Module
464

465
doMkDependHSMode, doMakeMode, doInteractiveMode,
466
  doAbiHashMode, showPackagesMode :: Mode
467
468
469
doMkDependHSMode = mkPostLoadMode DoMkDependHS
doMakeMode = mkPostLoadMode DoMake
doInteractiveMode = mkPostLoadMode DoInteractive
470
doAbiHashMode = mkPostLoadMode DoAbiHash
471
showPackagesMode = mkPostLoadMode ShowPackages
472
473
474
475
476
477
478
479
480
481

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
482
483
484
doFrontendMode :: String -> Mode
doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))

485
486
doBackpackMode :: Mode
doBackpackMode = mkPostLoadMode DoBackpack
Edward Z. Yang's avatar
Edward Z. Yang committed
487

488
489
490
491
492
493
mkPostLoadMode :: PostLoadMode -> Mode
mkPostLoadMode = Right . Right

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

495
496
497
498
499
500
501
502
isStopLnMode :: Mode -> Bool
isStopLnMode (Right (Right (StopBefore StopLn))) = True
isStopLnMode _ = False

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

503
504
505
506
isDoEvalMode :: Mode -> Bool
isDoEvalMode (Right (Right (DoEval _))) = True
isDoEvalMode _ = False

Ben Gamari's avatar
Ben Gamari committed
507
#if defined(GHCI)
508
isInteractiveMode :: PostLoadMode -> Bool
509
isInteractiveMode DoInteractive = True
dterei's avatar
dterei committed
510
isInteractiveMode _             = False
Ian Lynagh's avatar
Ian Lynagh committed
511
#endif
512
513

-- isInterpretiveMode: byte-code compiler involved
514
isInterpretiveMode :: PostLoadMode -> Bool
515
516
517
518
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _)    = True
isInterpretiveMode _             = False

519
needsInputsMode :: PostLoadMode -> Bool
dterei's avatar
dterei committed
520
521
522
523
needsInputsMode DoMkDependHS    = True
needsInputsMode (StopBefore _)  = True
needsInputsMode DoMake          = True
needsInputsMode _               = False
524

525
526
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
527
isLinkMode :: PostLoadMode -> Bool
528
isLinkMode (StopBefore StopLn) = True
dterei's avatar
dterei committed
529
isLinkMode DoMake              = True
530
531
isLinkMode DoInteractive       = True
isLinkMode (DoEval _)          = True
dterei's avatar
dterei committed
532
isLinkMode _                   = False
533

534
isCompManagerMode :: PostLoadMode -> Bool
535
536
537
538
539
540
541
542
isCompManagerMode DoMake        = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _)    = True
isCompManagerMode _             = False

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

543
parseModeFlags :: [Located String]
544
               -> IO (Mode,
545
546
                      [Located String],
                      [Located String])
547
parseModeFlags args = do
548
  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
549
          runCmdLine (processArgs mode_flags args)
550
551
                     (Nothing, [], [])
      mode = case mModeFlag of
552
             Nothing     -> doMakeMode
553
             Just (m, _) -> m
554
555
556
557
558

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

559
  return (mode, flags' ++ leftover, warns)
560

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

565
mode_flags :: [Flag ModeM]
566
567
mode_flags =
  [  ------- help / version ----------------------------------------------
568
569
570
571
572
573
574
575
576
577
    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))
578
  ] ++
579
  [ defFlag k'                      (PassFlag (setMode (printSetting k)))
580
  | k <- ["Project version",
581
          "Project Git commit id",
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
          "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",
599
600
          "C compiler link flags",
          "ld flags"],
601
602
603
604
    let k' = "-print-" ++ map (replaceSpace . toLower) k
        replaceSpace ' ' = '-'
        replaceSpace c   = c
  ] ++
605
      ------- interfaces ----------------------------------------------------
606
  [ defFlag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
607
                                               "--show-iface"))
608
609

      ------- primary modes ------------------------------------------------
610
611
612
613
614
615
616
  , 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))
617
  , defFlag "-backpack"    (PassFlag (setMode doBackpackMode))
618
619
620
  , 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
621
  , defFlag "-frontend"    (SepArg   (\s -> setMode (doFrontendMode s) "-frontend"))
622
623
  ]

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

637
638
639
640
641
642
643
644
                    -- If we have both --help and --interactive then we
                    -- want showGhciUsage
                    _ | isShowGhcUsageMode oldMode &&
                        isDoInteractiveMode newMode ->
                            ((showGhciUsageMode, oldFlag), [])
                      | isShowGhcUsageMode newMode &&
                        isDoInteractiveMode oldMode ->
                            ((showGhciUsageMode, newFlag), [])
645
646
647
648
649
650
651
652
653

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

654
655
656
657
658
659
660
661
662
663
                    -- 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)
664
665
666
667
668
669
670
671

                    -- --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)
672
673
674
675
676
677
678
679
680
681
682
683
684
                    -- 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 ++ "'"

685
686
addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
687
688
689
  (m, e, flags') <- getCmdLineState
  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
    where loc = "addFlag by " ++ flag ++ " on the commandline"
690

691
692
693
-- ----------------------------------------------------------------------------
-- Run --make mode

Thomas Schilling's avatar
Thomas Schilling committed
694
695
doMake :: [(String,Maybe Phase)] -> Ghc ()
doMake srcs  = do
696
    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
697

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

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

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

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

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

722
723
724
725
726
727

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

doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
728
  hsc_env <- newHscEnv dflags
729
730
  showIface hsc_env file

731
732
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
733

734
735
showBanner :: PostLoadMode -> DynFlags -> IO ()
showBanner _postLoadMode dflags = do
736
   let verb = verbosity dflags
Ian Lynagh's avatar
Ian Lynagh committed
737

Ben Gamari's avatar
Ben Gamari committed
738
#if defined(GHCI)
739
   -- Show the GHCi banner
740
   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
741
742
#endif

Ian Lynagh's avatar
Ian Lynagh committed
743
744
745
746
   -- 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
747
       hPutStr stderr ", stage "
Ian Lynagh's avatar
Ian Lynagh committed
748
749
750
       hPutStr stderr cStage
       hPutStr stderr " booted by GHC version "
       hPutStrLn stderr cBooterVersion
751

752
753
-- We print out a Read-friendly string, but a prettier one than the
-- Show instance gives us
754
755
756
showInfo :: DynFlags -> IO ()
showInfo dflags = do
        let sq x = " [" ++ x ++ "\n ]"
757
        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
758

759
showSupportedExtensions :: IO ()
760
showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
Ian Lynagh's avatar
Ian Lynagh committed
761

762
showVersion :: IO ()
763
764
showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)

765
766
showOptions :: Bool -> IO ()
showOptions isInteractive = putStr (unlines availableOptions)
767
    where
768
769
      availableOptions = concat [
        flagsForCompletion isInteractive,
Sylvain Henry's avatar
Sylvain Henry committed
770
        map ('-':) (getFlagNames mode_flags)
771
772
        ]
      getFlagNames opts         = map flagName opts
773

774
775
776
777
778
779
780
781
782
783
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
784
785
786
  usage <- readFile usage_path
  dump usage
  where
787
     dump ""          = return ()
788
     dump ('$':'$':s) = putStr progName >> dump s
789
     dump (c:s)       = putChar c >> dump s
790

791
dumpFinalStats :: DynFlags -> IO ()
dterei's avatar
dterei committed
792
dumpFinalStats dflags =
ian@well-typed.com's avatar
ian@well-typed.com committed
793
  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
794
795
796
797

dumpFastStringStats :: DynFlags -> IO ()
dumpFastStringStats dflags = do
  buckets <- getFastStringTable
Ian Lynagh's avatar
Ian Lynagh committed
798
  let (entries, longest, has_z) = countFS 0 0 0 buckets
799
      msg = text "FastString stats:" $$
dterei's avatar
dterei committed
800
801
802
803
804
805
806
807
808
809
            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.
810
811
812
  putMsg dflags msg
  where
   x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
Ian Lynagh's avatar
Ian Lynagh committed
813

Ian Lynagh's avatar
Ian Lynagh committed
814
815
816
countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
countFS entries longest has_z [] = (entries, longest, has_z)
countFS entries longest has_z (b:bs) =
817
  let
dterei's avatar
dterei committed
818
819
820
821
        len = length b
        longest' = max len longest
        entries' = entries + len
        has_zs = length (filter hasZEncoding b)
822
  in
Ian Lynagh's avatar
Ian Lynagh committed
823
        countFS entries' longest' (has_z + has_zs) bs
824

825
826
827
828
829
showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
showPackages       dflags = putStrLn (showSDoc dflags (pprPackages dflags))
dumpPackages       dflags = putMsg dflags (pprPackages dflags)
dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)

830
-- -----------------------------------------------------------------------------
Edward Z. Yang's avatar
Edward Z. Yang committed
831
832
833
-- Frontend plugin support

doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
Ben Gamari's avatar
Ben Gamari committed
834
#if !defined(GHCI)
835
doFrontend modname _ = pluginError [modname]
Edward Z. Yang's avatar
Edward Z. Yang committed
836
837
838
839
#else
doFrontend modname srcs = do
    hsc_env <- getSession
    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname
840
841
    frontend frontend_plugin
      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs
Edward Z. Yang's avatar
Edward Z. Yang committed
842
843
844
#endif

-- -----------------------------------------------------------------------------
845
846
847
848
849
850
851
852
853
-- 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.

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

860
861
862
863
864
865
866
-- | 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 ()
867
868
869
870
871
872
873
874
875
876
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
877
           Found _ m -> return m
878
           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
879
                          cannotFindModule dflags modname r
880

881
  mods <- mapM find_it strs
882

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

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

Ian Lynagh's avatar
Ian Lynagh committed
893
  putStrLn (showPpr dflags f)
894

895
896
897
898
-- -----------------------------------------------------------------------------
-- Util

unknownFlagsErr :: [String] -> a
899
unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
900
901
902
  where
    oneError f =
        "unrecognised flag: " ++ f ++ "\n" ++
903
        (case match f (nubSort allNonDeprecatedFlags) of
904
            [] -> ""
905
            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))
906
907
908
909
910
911
912
913
914
    -- 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
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929

{- 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
930
A byproduct of this, I believe, is that hooks are likely broken on OS
Austin Seipp's avatar
Austin Seipp committed
931
932
933
934
935
936
937
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 ()