1e9d0a2a96eef9a52da42f0732891cb920f9001a
[ghc.git] / ghc / Main.hs
1 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- GHC Driver program
6 --
7 -- (c) The University of Glasgow 2005
8 --
9 -----------------------------------------------------------------------------
10
11 module Main (main) where
12
13 -- The official GHC API
14 import qualified GHC
15 import GHC              ( -- DynFlags(..), HscTarget(..),
16                           -- GhcMode(..), GhcLink(..),
17                           Ghc, GhcMonad(..),
18                           LoadHowMuch(..) )
19 import CmdLineParser
20
21 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
22 import LoadIface        ( showIface )
23 import HscMain          ( newHscEnv )
24 import DriverPipeline   ( oneShot, compileFile )
25 import DriverMkDepend   ( doMkDependHS )
26 #ifdef GHCI
27 import InteractiveUI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
28 #endif
29
30
31 -- Various other random stuff that we need
32 import Config
33 import Constants
34 import HscTypes
35 import Packages         ( dumpPackages )
36 import DriverPhases     ( Phase(..), isSourceFilename, anyHsc,
37                           startPhase, isHaskellSrcFilename )
38 import BasicTypes       ( failed )
39 import StaticFlags
40 import StaticFlagParser
41 import DynFlags
42 import ErrUtils
43 import FastString
44 import Outputable
45 import SrcLoc
46 import Util
47 import Panic
48 import MonadUtils       ( liftIO )
49
50 -- Imports for --abi-hash
51 import LoadIface           ( loadUserInterface )
52 import Module              ( mkModuleName )
53 import Finder              ( findImportedModule, cannotFindInterface )
54 import TcRnMonad           ( initIfaceCheck )
55 import Binary              ( openBinMem, put_, fingerprintBinMem )
56
57 -- Standard Haskell libraries
58 import System.IO
59 import System.Environment
60 import System.Exit
61 import System.FilePath
62 import Control.Monad
63 import Data.Char
64 import Data.List
65 import Data.Maybe
66
67 -----------------------------------------------------------------------------
68 -- ToDo:
69
70 -- time commands when run with -v
71 -- user ways
72 -- Win32 support: proper signal handling
73 -- reading the package configuration file is too slow
74 -- -K<size>
75
76 -----------------------------------------------------------------------------
77 -- GHC's command-line interface
78
79 main :: IO ()
80 main = do
81    hSetBuffering stdout NoBuffering
82    hSetBuffering stderr NoBuffering
83    GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
84     -- 1. extract the -B flag from the args
85     argv0 <- getArgs
86
87     let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
88         mbMinusB | null minusB_args = Nothing
89                  | otherwise = Just (drop 2 (last minusB_args))
90
91     let argv1' = map (mkGeneralLocated "on the commandline") argv1
92     (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
93
94     -- 2. Parse the "mode" flags (--make, --interactive etc.)
95     (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
96
97     let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
98
99     -- If all we want to do is something like showing the version number
100     -- then do it now, before we start a GHC session etc. This makes
101     -- getting basic information much more resilient.
102
103     -- In particular, if we wait until later before giving the version
104     -- number then bootstrapping gets confused, as it tries to find out
105     -- what version of GHC it's using before package.conf exists, so
106     -- starting the session fails.
107     case mode of
108         Left preStartupMode ->
109             do case preStartupMode of
110                    ShowSupportedExtensions -> showSupportedExtensions
111                    ShowVersion             -> showVersion
112                    ShowNumVersion          -> putStrLn cProjectVersion
113                    Print str               -> putStrLn str
114         Right postStartupMode ->
115             -- start our GHC session
116             GHC.runGhc mbMinusB $ do
117
118             dflags <- GHC.getSessionDynFlags
119
120             case postStartupMode of
121                 Left preLoadMode ->
122                     liftIO $ do
123                         case preLoadMode of
124                             ShowInfo               -> showInfo dflags
125                             ShowGhcUsage           -> showGhcUsage  dflags
126                             ShowGhciUsage          -> showGhciUsage dflags
127                             PrintWithDynFlags f    -> putStrLn (f dflags)
128                 Right postLoadMode ->
129                     main' postLoadMode dflags argv3 flagWarnings
130
131 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
132       -> Ghc ()
133 main' postLoadMode dflags0 args flagWarnings = do
134   -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
135   -- can be further adjusted on a module by module basis, using only
136   -- the -fvia-C and -fasm flags.  If the default HscTarget is not
137   -- HscC or HscAsm, -fvia-C and -fasm have no effect.
138   let dflt_target = hscTarget dflags0
139       (mode, lang, link)
140          = case postLoadMode of
141                DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
142                DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
143                DoMake          -> (CompManager, dflt_target,    LinkBinary)
144                DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
145                DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
146                _               -> (OneShot,     dflt_target,    LinkBinary)
147
148   let dflags1 = dflags0{ ghcMode   = mode,
149                          hscTarget = lang,
150                          ghcLink   = link,
151                          -- leave out hscOutName for now
152                          hscOutName = panic "Main.main:hscOutName not set",
153                          verbosity = case postLoadMode of
154                                          DoEval _ -> 0
155                                          _other   -> 1
156                         }
157
158       -- turn on -fimplicit-import-qualified for GHCi now, so that it
159       -- can be overriden from the command-line
160       -- XXX: this should really be in the interactive DynFlags, but
161       -- we don't set that until later in interactiveUI
162       dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled
163                | DoEval _      <- postLoadMode = imp_qual_enabled
164                | otherwise                 = dflags1
165         where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified
166
167         -- The rest of the arguments are "dynamic"
168         -- Leftover ones are presumably files
169   (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
170
171   GHC.prettyPrintGhcErrors dflags2 $ do
172
173   let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
174
175   handleSourceError (\e -> do
176        GHC.printException e
177        liftIO $ exitWith (ExitFailure 1)) $ do
178          liftIO $ handleFlagWarnings dflags2 flagWarnings'
179
180         -- make sure we clean up after ourselves
181   GHC.defaultCleanupHandler dflags2 $ do
182
183   liftIO $ showBanner postLoadMode dflags2
184
185   -- we've finished manipulating the DynFlags, update the session
186   _ <- GHC.setSessionDynFlags dflags2
187   dflags3 <- GHC.getSessionDynFlags
188   hsc_env <- GHC.getSession
189
190   let
191      -- To simplify the handling of filepaths, we normalise all filepaths right
192      -- away - e.g., for win32 platforms, backslashes are converted
193      -- into forward slashes.
194     normal_fileish_paths = map (normalise . unLoc) fileish_args
195     (srcs, objs)         = partition_args normal_fileish_paths [] []
196
197   -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
198   --       the command-line.
199   liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)
200
201         ---------------- Display configuration -----------
202   when (verbosity dflags3 >= 4) $
203         liftIO $ dumpPackages dflags3
204
205   when (verbosity dflags3 >= 3) $ do
206         liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
207
208         ---------------- Final sanity checking -----------
209   liftIO $ checkOptions postLoadMode dflags3 srcs objs
210
211   ---------------- Do the business -----------
212   handleSourceError (\e -> do
213        GHC.printException e
214        liftIO $ exitWith (ExitFailure 1)) $ do
215     case postLoadMode of
216        ShowInterface f        -> liftIO $ doShowIface dflags3 f
217        DoMake                 -> doMake srcs
218        DoMkDependHS           -> doMkDependHS (map fst srcs)
219        StopBefore p           -> liftIO (oneShot hsc_env p srcs)
220        DoInteractive          -> ghciUI srcs Nothing
221        DoEval exprs           -> ghciUI srcs $ Just $ reverse exprs
222        DoAbiHash              -> abiHash srcs
223
224   liftIO $ dumpFinalStats dflags3
225
226 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
227 #ifndef GHCI
228 ghciUI _ _ = ghcError (CmdLineError "not built for interactive use")
229 #else
230 ghciUI     = interactiveUI defaultGhciSettings
231 #endif
232
233 -- -----------------------------------------------------------------------------
234 -- Splitting arguments into source files and object files.  This is where we
235 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
236 -- file indicating the phase specified by the -x option in force, if any.
237
238 partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
239                -> ([(String, Maybe Phase)], [String])
240 partition_args [] srcs objs = (reverse srcs, reverse objs)
241 partition_args ("-x":suff:args) srcs objs
242   | "none" <- suff      = partition_args args srcs objs
243   | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
244   | otherwise           = partition_args rest (these_srcs ++ srcs) objs
245         where phase = startPhase suff
246               (slurp,rest) = break (== "-x") args
247               these_srcs = zip slurp (repeat (Just phase))
248 partition_args (arg:args) srcs objs
249   | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
250   | otherwise               = partition_args args srcs (arg:objs)
251
252     {-
253       We split out the object files (.o, .dll) and add them
254       to v_Ld_inputs for use by the linker.
255
256       The following things should be considered compilation manager inputs:
257
258        - haskell source files (strings ending in .hs, .lhs or other
259          haskellish extension),
260
261        - module names (not forgetting hierarchical module names),
262
263        - things beginning with '-' are flags that were not recognised by
264          the flag parser, and we want them to generate errors later in
265          checkOptions, so we class them as source files (#5921)
266
267        - and finally we consider everything not containing a '.' to be
268          a comp manager input, as shorthand for a .hs or .lhs filename.
269
270       Everything else is considered to be a linker object, and passed
271       straight through to the linker.
272     -}
273 looks_like_an_input :: String -> Bool
274 looks_like_an_input m =  isSourceFilename m
275                       || looksLikeModuleName m
276                       || "-" `isPrefixOf` m
277                       || '.' `notElem` m
278
279 -- -----------------------------------------------------------------------------
280 -- Option sanity checks
281
282 -- | Ensure sanity of options.
283 --
284 -- Throws 'UsageError' or 'CmdLineError' if not.
285 checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
286      -- Final sanity checking before kicking off a compilation (pipeline).
287 checkOptions mode dflags srcs objs = do
288      -- Complain about any unknown flags
289    let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
290    when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
291
292    when (notNull (filter isRTSWay (wayNames dflags))
293          && isInterpretiveMode mode) $
294         hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
295
296         -- -prof and --interactive are not a good combination
297    when (notNull (filter (not . isRTSWay) (wayNames dflags))
298          && isInterpretiveMode mode) $
299       do ghcError (UsageError
300                    "--interactive can't be used with -prof or -unreg.")
301         -- -ohi sanity check
302    if (isJust (outputHi dflags) &&
303       (isCompManagerMode mode || srcs `lengthExceeds` 1))
304         then ghcError (UsageError "-ohi can only be used when compiling a single source file")
305         else do
306
307         -- -o sanity checking
308    if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
309          && not (isLinkMode mode))
310         then ghcError (UsageError "can't apply -o to multiple source files")
311         else do
312
313    let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
314
315    when (not_linking && not (null objs)) $
316         hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
317
318         -- Check that there are some input files
319         -- (except in the interactive case)
320    if null srcs && (null objs || not_linking) && needsInputsMode mode
321         then ghcError (UsageError "no input files")
322         else do
323
324      -- Verify that output files point somewhere sensible.
325    verifyOutputFiles dflags
326
327
328 -- Compiler output options
329
330 -- called to verify that the output files & directories
331 -- point somewhere valid.
332 --
333 -- The assumption is that the directory portion of these output
334 -- options will have to exist by the time 'verifyOutputFiles'
335 -- is invoked.
336 --
337 verifyOutputFiles :: DynFlags -> IO ()
338 verifyOutputFiles dflags = do
339   -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
340   let ofile = outputFile dflags
341   when (isJust ofile) $ do
342      let fn = fromJust ofile
343      flg <- doesDirNameExist fn
344      when (not flg) (nonExistentDir "-o" fn)
345   let ohi = outputHi dflags
346   when (isJust ohi) $ do
347      let hi = fromJust ohi
348      flg <- doesDirNameExist hi
349      when (not flg) (nonExistentDir "-ohi" hi)
350  where
351    nonExistentDir flg dir =
352      ghcError (CmdLineError ("error: directory portion of " ++
353                              show dir ++ " does not exist (used with " ++
354                              show flg ++ " option.)"))
355
356 -----------------------------------------------------------------------------
357 -- GHC modes of operation
358
359 type Mode = Either PreStartupMode PostStartupMode
360 type PostStartupMode = Either PreLoadMode PostLoadMode
361
362 data PreStartupMode
363   = ShowVersion             -- ghc -V/--version
364   | ShowNumVersion          -- ghc --numeric-version
365   | ShowSupportedExtensions -- ghc --supported-extensions
366   | Print String            -- ghc --print-foo
367
368 showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
369 showVersionMode             = mkPreStartupMode ShowVersion
370 showNumVersionMode          = mkPreStartupMode ShowNumVersion
371 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
372
373 mkPreStartupMode :: PreStartupMode -> Mode
374 mkPreStartupMode = Left
375
376 isShowVersionMode :: Mode -> Bool
377 isShowVersionMode (Left ShowVersion) = True
378 isShowVersionMode _ = False
379
380 isShowNumVersionMode :: Mode -> Bool
381 isShowNumVersionMode (Left ShowNumVersion) = True
382 isShowNumVersionMode _ = False
383
384 data PreLoadMode
385   = ShowGhcUsage                           -- ghc -?
386   | ShowGhciUsage                          -- ghci -?
387   | ShowInfo                               -- ghc --info
388   | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
389
390 showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
391 showGhcUsageMode = mkPreLoadMode ShowGhcUsage
392 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
393 showInfoMode = mkPreLoadMode ShowInfo
394
395 printSetting :: String -> Mode
396 printSetting k = mkPreLoadMode (PrintWithDynFlags f)
397     where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
398                    $ lookup k (compilerInfo dflags)
399
400 mkPreLoadMode :: PreLoadMode -> Mode
401 mkPreLoadMode = Right . Left
402
403 isShowGhcUsageMode :: Mode -> Bool
404 isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
405 isShowGhcUsageMode _ = False
406
407 isShowGhciUsageMode :: Mode -> Bool
408 isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
409 isShowGhciUsageMode _ = False
410
411 data PostLoadMode
412   = ShowInterface FilePath  -- ghc --show-iface
413   | DoMkDependHS            -- ghc -M
414   | StopBefore Phase        -- ghc -E | -C | -S
415                             -- StopBefore StopLn is the default
416   | DoMake                  -- ghc --make
417   | DoInteractive           -- ghc --interactive
418   | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
419   | DoAbiHash               -- ghc --abi-hash
420
421 doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
422 doMkDependHSMode = mkPostLoadMode DoMkDependHS
423 doMakeMode = mkPostLoadMode DoMake
424 doInteractiveMode = mkPostLoadMode DoInteractive
425 doAbiHashMode = mkPostLoadMode DoAbiHash
426
427 showInterfaceMode :: FilePath -> Mode
428 showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
429
430 stopBeforeMode :: Phase -> Mode
431 stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
432
433 doEvalMode :: String -> Mode
434 doEvalMode str = mkPostLoadMode (DoEval [str])
435
436 mkPostLoadMode :: PostLoadMode -> Mode
437 mkPostLoadMode = Right . Right
438
439 isDoInteractiveMode :: Mode -> Bool
440 isDoInteractiveMode (Right (Right DoInteractive)) = True
441 isDoInteractiveMode _ = False
442
443 isStopLnMode :: Mode -> Bool
444 isStopLnMode (Right (Right (StopBefore StopLn))) = True
445 isStopLnMode _ = False
446
447 isDoMakeMode :: Mode -> Bool
448 isDoMakeMode (Right (Right DoMake)) = True
449 isDoMakeMode _ = False
450
451 #ifdef GHCI
452 isInteractiveMode :: PostLoadMode -> Bool
453 isInteractiveMode DoInteractive = True
454 isInteractiveMode _             = False
455 #endif
456
457 -- isInterpretiveMode: byte-code compiler involved
458 isInterpretiveMode :: PostLoadMode -> Bool
459 isInterpretiveMode DoInteractive = True
460 isInterpretiveMode (DoEval _)    = True
461 isInterpretiveMode _             = False
462
463 needsInputsMode :: PostLoadMode -> Bool
464 needsInputsMode DoMkDependHS    = True
465 needsInputsMode (StopBefore _)  = True
466 needsInputsMode DoMake          = True
467 needsInputsMode _               = False
468
469 -- True if we are going to attempt to link in this mode.
470 -- (we might not actually link, depending on the GhcLink flag)
471 isLinkMode :: PostLoadMode -> Bool
472 isLinkMode (StopBefore StopLn) = True
473 isLinkMode DoMake              = True
474 isLinkMode DoInteractive       = True
475 isLinkMode (DoEval _)          = True
476 isLinkMode _                   = False
477
478 isCompManagerMode :: PostLoadMode -> Bool
479 isCompManagerMode DoMake        = True
480 isCompManagerMode DoInteractive = True
481 isCompManagerMode (DoEval _)    = True
482 isCompManagerMode _             = False
483
484 -- -----------------------------------------------------------------------------
485 -- Parsing the mode flag
486
487 parseModeFlags :: [Located String]
488                -> IO (Mode,
489                       [Located String],
490                       [Located String])
491 parseModeFlags args = do
492   let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
493           runCmdLine (processArgs mode_flags args)
494                      (Nothing, [], [])
495       mode = case mModeFlag of
496              Nothing     -> doMakeMode
497              Just (m, _) -> m
498       errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
499   when (not (null errs)) $ ghcError $ errorsToGhcException errs
500   return (mode, flags' ++ leftover, warns)
501
502 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
503   -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
504   -- so we collect the new ones and return them.
505
506 mode_flags :: [Flag ModeM]
507 mode_flags =
508   [  ------- help / version ----------------------------------------------
509     Flag "?"                     (PassFlag (setMode showGhcUsageMode))
510   , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
511   , Flag "V"                     (PassFlag (setMode showVersionMode))
512   , Flag "-version"              (PassFlag (setMode showVersionMode))
513   , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
514   , Flag "-info"                 (PassFlag (setMode showInfoMode))
515   , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
516   , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
517   ] ++
518   [ Flag k'                      (PassFlag (setMode (printSetting k)))
519   | k <- ["Project version",
520           "Booter version",
521           "Stage",
522           "Build platform",
523           "Host platform",
524           "Target platform",
525           "Have interpreter",
526           "Object splitting supported",
527           "Have native code generator",
528           "Support SMP",
529           "Unregisterised",
530           "Tables next to code",
531           "RTS ways",
532           "Leading underscore",
533           "Debug on",
534           "LibDir",
535           "Global Package DB",
536           "C compiler flags",
537           "Gcc Linker flags",
538           "Ld Linker flags"],
539     let k' = "-print-" ++ map (replaceSpace . toLower) k
540         replaceSpace ' ' = '-'
541         replaceSpace c   = c
542   ] ++
543       ------- interfaces ----------------------------------------------------
544   [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
545                                                "--show-iface"))
546
547       ------- primary modes ------------------------------------------------
548   , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
549                                             addFlag "-no-link" f))
550   , Flag "M"            (PassFlag (setMode doMkDependHSMode))
551   , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
552   , Flag "C"            (PassFlag setGenerateC)
553   , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
554   , Flag "-make"        (PassFlag (setMode doMakeMode))
555   , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
556   , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
557   , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
558   ]
559
560 setGenerateC :: String -> EwM ModeM ()
561 setGenerateC f = do -- TODO: We used to warn and ignore when
562                     -- unregisterised, but we no longer know whether
563                     -- we are unregisterised at this point. Should
564                     -- we check later on?
565                     setMode (stopBeforeMode HCc) f
566                     addFlag "-fvia-C" f
567
568 setMode :: Mode -> String -> EwM ModeM ()
569 setMode newMode newFlag = liftEwM $ do
570     (mModeFlag, errs, flags') <- getCmdLineState
571     let (modeFlag', errs') =
572             case mModeFlag of
573             Nothing -> ((newMode, newFlag), errs)
574             Just (oldMode, oldFlag) ->
575                 case (oldMode, newMode) of
576                     -- -c/--make are allowed together, and mean --make -no-link
577                     _ |  isStopLnMode oldMode && isDoMakeMode newMode
578                       || isStopLnMode newMode && isDoMakeMode oldMode ->
579                       ((doMakeMode, "--make"), [])
580
581                     -- If we have both --help and --interactive then we
582                     -- want showGhciUsage
583                     _ | isShowGhcUsageMode oldMode &&
584                         isDoInteractiveMode newMode ->
585                             ((showGhciUsageMode, oldFlag), [])
586                       | isShowGhcUsageMode newMode &&
587                         isDoInteractiveMode oldMode ->
588                             ((showGhciUsageMode, newFlag), [])
589                     -- Otherwise, --help/--version/--numeric-version always win
590                       | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
591                       | isDominantFlag newMode -> ((newMode, newFlag), [])
592                     -- We need to accumulate eval flags like "-e foo -e bar"
593                     (Right (Right (DoEval esOld)),
594                      Right (Right (DoEval [eNew]))) ->
595                         ((Right (Right (DoEval (eNew : esOld))), oldFlag),
596                          errs)
597                     -- Saying e.g. --interactive --interactive is OK
598                     _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
599                     -- Otherwise, complain
600                     _ -> let err = flagMismatchErr oldFlag newFlag
601                          in ((oldMode, oldFlag), err : errs)
602     putCmdLineState (Just modeFlag', errs', flags')
603   where isDominantFlag f = isShowGhcUsageMode   f ||
604                            isShowGhciUsageMode  f ||
605                            isShowVersionMode    f ||
606                            isShowNumVersionMode f
607
608 flagMismatchErr :: String -> String -> String
609 flagMismatchErr oldFlag newFlag
610     = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"
611
612 addFlag :: String -> String -> EwM ModeM ()
613 addFlag s flag = liftEwM $ do
614   (m, e, flags') <- getCmdLineState
615   putCmdLineState (m, e, mkGeneralLocated loc s : flags')
616     where loc = "addFlag by " ++ flag ++ " on the commandline"
617
618 -- ----------------------------------------------------------------------------
619 -- Run --make mode
620
621 doMake :: [(String,Maybe Phase)] -> Ghc ()
622 doMake srcs  = do
623     let (hs_srcs, non_hs_srcs) = partition haskellish srcs
624
625         haskellish (f,Nothing) =
626           looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
627         haskellish (_,Just phase) =
628           phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
629
630     hsc_env <- GHC.getSession
631
632     -- if we have no haskell sources from which to do a dependency
633     -- analysis, then just do one-shot compilation and/or linking.
634     -- This means that "ghc Foo.o Bar.o -o baz" links the program as
635     -- we expect.
636     if (null hs_srcs)
637        then liftIO (oneShot hsc_env StopLn srcs)
638        else do
639
640     o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
641                  non_hs_srcs
642     liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
643
644     targets <- mapM (uncurry GHC.guessTarget) hs_srcs
645     GHC.setTargets targets
646     ok_flag <- GHC.load LoadAllTargets
647
648     when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
649     return ()
650
651
652 -- ---------------------------------------------------------------------------
653 -- --show-iface mode
654
655 doShowIface :: DynFlags -> FilePath -> IO ()
656 doShowIface dflags file = do
657   hsc_env <- newHscEnv dflags
658   showIface hsc_env file
659
660 -- ---------------------------------------------------------------------------
661 -- Various banners and verbosity output.
662
663 showBanner :: PostLoadMode -> DynFlags -> IO ()
664 showBanner _postLoadMode dflags = do
665    let verb = verbosity dflags
666
667 #ifdef GHCI
668    -- Show the GHCi banner
669    when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
670 #endif
671
672    -- Display details of the configuration in verbose mode
673    when (verb >= 2) $
674     do hPutStr stderr "Glasgow Haskell Compiler, Version "
675        hPutStr stderr cProjectVersion
676        hPutStr stderr ", stage "
677        hPutStr stderr cStage
678        hPutStr stderr " booted by GHC version "
679        hPutStrLn stderr cBooterVersion
680
681 -- We print out a Read-friendly string, but a prettier one than the
682 -- Show instance gives us
683 showInfo :: DynFlags -> IO ()
684 showInfo dflags = do
685         let sq x = " [" ++ x ++ "\n ]"
686         putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
687
688 showSupportedExtensions :: IO ()
689 showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
690
691 showVersion :: IO ()
692 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
693
694 showGhcUsage :: DynFlags -> IO ()
695 showGhcUsage = showUsage False
696
697 showGhciUsage :: DynFlags -> IO ()
698 showGhciUsage = showUsage True
699
700 showUsage :: Bool -> DynFlags -> IO ()
701 showUsage ghci dflags = do
702   let usage_path = if ghci then ghciUsagePath dflags
703                            else ghcUsagePath dflags
704   usage <- readFile usage_path
705   dump usage
706   where
707      dump ""          = return ()
708      dump ('$':'$':s) = putStr progName >> dump s
709      dump (c:s)       = putChar c >> dump s
710
711 dumpFinalStats :: DynFlags -> IO ()
712 dumpFinalStats dflags =
713   when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
714
715 dumpFastStringStats :: DynFlags -> IO ()
716 dumpFastStringStats dflags = do
717   buckets <- getFastStringTable
718   let (entries, longest, has_z) = countFS 0 0 0 buckets
719       msg = text "FastString stats:" $$
720             nest 4 (vcat [text "size:           " <+> int (length buckets),
721                           text "entries:        " <+> int entries,
722                           text "longest chain:  " <+> int longest,
723                           text "has z-encoding: " <+> (has_z `pcntOf` entries)
724                          ])
725         -- we usually get more "has z-encoding" than "z-encoded", because
726         -- when we z-encode a string it might hash to the exact same string,
727         -- which will is not counted as "z-encoded".  Only strings whose
728         -- Z-encoding is different from the original string are counted in
729         -- the "z-encoded" total.
730   putMsg dflags msg
731   where
732    x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
733
734 countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
735 countFS entries longest has_z [] = (entries, longest, has_z)
736 countFS entries longest has_z (b:bs) =
737   let
738         len = length b
739         longest' = max len longest
740         entries' = entries + len
741         has_zs = length (filter hasZEncoding b)
742   in
743         countFS entries' longest' (has_z + has_zs) bs
744
745 -- -----------------------------------------------------------------------------
746 -- ABI hash support
747
748 {-
749         ghc --abi-hash Data.Foo System.Bar
750
751 Generates a combined hash of the ABI for modules Data.Foo and
752 System.Bar.  The modules must already be compiled, and appropriate -i
753 options may be necessary in order to find the .hi files.
754
755 This is used by Cabal for generating the InstalledPackageId for a
756 package.  The InstalledPackageId must change when the visible ABI of
757 the package chagnes, so during registration Cabal calls ghc --abi-hash
758 to get a hash of the package's ABI.
759 -}
760
761 abiHash :: [(String, Maybe Phase)] -> Ghc ()
762 abiHash strs = do
763   hsc_env <- getSession
764   let dflags = hsc_dflags hsc_env
765
766   liftIO $ do
767
768   let find_it str = do
769          let modname = mkModuleName str
770          r <- findImportedModule hsc_env modname Nothing
771          case r of
772            Found _ m -> return m
773            _error    -> ghcError $ CmdLineError $ showSDoc dflags $
774                           cannotFindInterface dflags modname r
775
776   mods <- mapM find_it (map fst strs)
777
778   let get_iface modl = loadUserInterface False (text "abiHash") modl
779   ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
780
781   bh <- openBinMem (3*1024) -- just less than a block
782   put_ bh hiVersion
783     -- package hashes change when the compiler version changes (for now)
784     -- see #5328
785   mapM_ (put_ bh . mi_mod_hash) ifaces
786   f <- fingerprintBinMem bh
787
788   putStrLn (showPpr dflags f)
789
790 -- -----------------------------------------------------------------------------
791 -- Util
792
793 unknownFlagsErr :: [String] -> a
794 unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))
795