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