Updated output for test ghci024
[ghc.git] / ghc / Main.hs
1 {-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
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 ( pprPackages, pprPackagesSimple, pprModuleMap )
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 isInteractive -> showOptions isInteractive
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 $ dumpPackagesSimple 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
221 when (dopt Opt_D_dump_mod_map dflags6) . liftIO $
222 printInfoForUser (dflags6 { pprCols = 200 })
223 (pkgQual dflags6) (pprModuleMap dflags6)
224
225 ---------------- Final sanity checking -----------
226 liftIO $ checkOptions postLoadMode dflags6 srcs objs
227
228 ---------------- Do the business -----------
229 handleSourceError (\e -> do
230 GHC.printException e
231 liftIO $ exitWith (ExitFailure 1)) $ do
232 case postLoadMode of
233 ShowInterface f -> liftIO $ doShowIface dflags6 f
234 DoMake -> doMake srcs
235 DoMkDependHS -> doMkDependHS (map fst srcs)
236 StopBefore p -> liftIO (oneShot hsc_env p srcs)
237 DoInteractive -> ghciUI srcs Nothing
238 DoEval exprs -> ghciUI srcs $ Just $ reverse exprs
239 DoAbiHash -> abiHash (map fst srcs)
240 ShowPackages -> liftIO $ showPackages dflags6
241
242 liftIO $ dumpFinalStats dflags6
243
244 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
245 #ifndef GHCI
246 ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
247 #else
248 ghciUI = interactiveUI defaultGhciSettings
249 #endif
250
251 -- -----------------------------------------------------------------------------
252 -- Splitting arguments into source files and object files. This is where we
253 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
254 -- file indicating the phase specified by the -x option in force, if any.
255
256 partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
257 -> ([(String, Maybe Phase)], [String])
258 partition_args [] srcs objs = (reverse srcs, reverse objs)
259 partition_args ("-x":suff:args) srcs objs
260 | "none" <- suff = partition_args args srcs objs
261 | StopLn <- phase = partition_args args srcs (slurp ++ objs)
262 | otherwise = partition_args rest (these_srcs ++ srcs) objs
263 where phase = startPhase suff
264 (slurp,rest) = break (== "-x") args
265 these_srcs = zip slurp (repeat (Just phase))
266 partition_args (arg:args) srcs objs
267 | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
268 | otherwise = partition_args args srcs (arg:objs)
269
270 {-
271 We split out the object files (.o, .dll) and add them
272 to ldInputs for use by the linker.
273
274 The following things should be considered compilation manager inputs:
275
276 - haskell source files (strings ending in .hs, .lhs or other
277 haskellish extension),
278
279 - module names (not forgetting hierarchical module names),
280
281 - things beginning with '-' are flags that were not recognised by
282 the flag parser, and we want them to generate errors later in
283 checkOptions, so we class them as source files (#5921)
284
285 - and finally we consider everything not containing a '.' to be
286 a comp manager input, as shorthand for a .hs or .lhs filename.
287
288 Everything else is considered to be a linker object, and passed
289 straight through to the linker.
290 -}
291 looks_like_an_input :: String -> Bool
292 looks_like_an_input m = isSourceFilename m
293 || looksLikeModuleName m
294 || "-" `isPrefixOf` m
295 || '.' `notElem` m
296
297 -- -----------------------------------------------------------------------------
298 -- Option sanity checks
299
300 -- | Ensure sanity of options.
301 --
302 -- Throws 'UsageError' or 'CmdLineError' if not.
303 checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
304 -- Final sanity checking before kicking off a compilation (pipeline).
305 checkOptions mode dflags srcs objs = do
306 -- Complain about any unknown flags
307 let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
308 when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
309
310 when (notNull (filter wayRTSOnly (ways dflags))
311 && isInterpretiveMode mode) $
312 hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
313
314 -- -prof and --interactive are not a good combination
315 when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
316 && isInterpretiveMode mode) $
317 do throwGhcException (UsageError
318 "--interactive can't be used with -prof.")
319 -- -ohi sanity check
320 if (isJust (outputHi dflags) &&
321 (isCompManagerMode mode || srcs `lengthExceeds` 1))
322 then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
323 else do
324
325 -- -o sanity checking
326 if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
327 && not (isLinkMode mode))
328 then throwGhcException (UsageError "can't apply -o to multiple source files")
329 else do
330
331 let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
332
333 when (not_linking && not (null objs)) $
334 hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
335
336 -- Check that there are some input files
337 -- (except in the interactive case)
338 if null srcs && (null objs || not_linking) && needsInputsMode mode
339 then throwGhcException (UsageError "no input files")
340 else do
341
342 case mode of
343 StopBefore HCc | hscTarget dflags /= HscC
344 -> throwGhcException $ UsageError $
345 "the option -C is only available with an unregisterised GHC"
346 _ -> return ()
347
348 -- Verify that output files point somewhere sensible.
349 verifyOutputFiles dflags
350
351 -- Compiler output options
352
353 -- Called to verify that the output files point somewhere valid.
354 --
355 -- The assumption is that the directory portion of these output
356 -- options will have to exist by the time 'verifyOutputFiles'
357 -- is invoked.
358 --
359 -- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
360 -- they don't exist, so don't check for those here (#2278).
361 verifyOutputFiles :: DynFlags -> IO ()
362 verifyOutputFiles dflags = do
363 let ofile = outputFile dflags
364 when (isJust ofile) $ do
365 let fn = fromJust ofile
366 flg <- doesDirNameExist fn
367 when (not flg) (nonExistentDir "-o" fn)
368 let ohi = outputHi dflags
369 when (isJust ohi) $ do
370 let hi = fromJust ohi
371 flg <- doesDirNameExist hi
372 when (not flg) (nonExistentDir "-ohi" hi)
373 where
374 nonExistentDir flg dir =
375 throwGhcException (CmdLineError ("error: directory portion of " ++
376 show dir ++ " does not exist (used with " ++
377 show flg ++ " option.)"))
378
379 -----------------------------------------------------------------------------
380 -- GHC modes of operation
381
382 type Mode = Either PreStartupMode PostStartupMode
383 type PostStartupMode = Either PreLoadMode PostLoadMode
384
385 data PreStartupMode
386 = ShowVersion -- ghc -V/--version
387 | ShowNumVersion -- ghc --numeric-version
388 | ShowSupportedExtensions -- ghc --supported-extensions
389 | ShowOptions Bool {- isInteractive -} -- ghc --show-options
390
391 showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
392 showVersionMode = mkPreStartupMode ShowVersion
393 showNumVersionMode = mkPreStartupMode ShowNumVersion
394 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
395 showOptionsMode = mkPreStartupMode (ShowOptions False)
396
397 mkPreStartupMode :: PreStartupMode -> Mode
398 mkPreStartupMode = Left
399
400 isShowVersionMode :: Mode -> Bool
401 isShowVersionMode (Left ShowVersion) = True
402 isShowVersionMode _ = False
403
404 isShowNumVersionMode :: Mode -> Bool
405 isShowNumVersionMode (Left ShowNumVersion) = True
406 isShowNumVersionMode _ = False
407
408 data PreLoadMode
409 = ShowGhcUsage -- ghc -?
410 | ShowGhciUsage -- ghci -?
411 | ShowInfo -- ghc --info
412 | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
413
414 showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
415 showGhcUsageMode = mkPreLoadMode ShowGhcUsage
416 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
417 showInfoMode = mkPreLoadMode ShowInfo
418
419 printSetting :: String -> Mode
420 printSetting k = mkPreLoadMode (PrintWithDynFlags f)
421 where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
422 $ lookup k (compilerInfo dflags)
423
424 mkPreLoadMode :: PreLoadMode -> Mode
425 mkPreLoadMode = Right . Left
426
427 isShowGhcUsageMode :: Mode -> Bool
428 isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
429 isShowGhcUsageMode _ = False
430
431 isShowGhciUsageMode :: Mode -> Bool
432 isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
433 isShowGhciUsageMode _ = False
434
435 data PostLoadMode
436 = ShowInterface FilePath -- ghc --show-iface
437 | DoMkDependHS -- ghc -M
438 | StopBefore Phase -- ghc -E | -C | -S
439 -- StopBefore StopLn is the default
440 | DoMake -- ghc --make
441 | DoInteractive -- ghc --interactive
442 | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
443 | DoAbiHash -- ghc --abi-hash
444 | ShowPackages -- ghc --show-packages
445
446 doMkDependHSMode, doMakeMode, doInteractiveMode,
447 doAbiHashMode, showPackagesMode :: Mode
448 doMkDependHSMode = mkPostLoadMode DoMkDependHS
449 doMakeMode = mkPostLoadMode DoMake
450 doInteractiveMode = mkPostLoadMode DoInteractive
451 doAbiHashMode = mkPostLoadMode DoAbiHash
452 showPackagesMode = mkPostLoadMode ShowPackages
453
454 showInterfaceMode :: FilePath -> Mode
455 showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
456
457 stopBeforeMode :: Phase -> Mode
458 stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
459
460 doEvalMode :: String -> Mode
461 doEvalMode str = mkPostLoadMode (DoEval [str])
462
463 mkPostLoadMode :: PostLoadMode -> Mode
464 mkPostLoadMode = Right . Right
465
466 isDoInteractiveMode :: Mode -> Bool
467 isDoInteractiveMode (Right (Right DoInteractive)) = True
468 isDoInteractiveMode _ = False
469
470 isStopLnMode :: Mode -> Bool
471 isStopLnMode (Right (Right (StopBefore StopLn))) = True
472 isStopLnMode _ = False
473
474 isDoMakeMode :: Mode -> Bool
475 isDoMakeMode (Right (Right DoMake)) = True
476 isDoMakeMode _ = False
477
478 #ifdef GHCI
479 isInteractiveMode :: PostLoadMode -> Bool
480 isInteractiveMode DoInteractive = True
481 isInteractiveMode _ = False
482 #endif
483
484 -- isInterpretiveMode: byte-code compiler involved
485 isInterpretiveMode :: PostLoadMode -> Bool
486 isInterpretiveMode DoInteractive = True
487 isInterpretiveMode (DoEval _) = True
488 isInterpretiveMode _ = False
489
490 needsInputsMode :: PostLoadMode -> Bool
491 needsInputsMode DoMkDependHS = True
492 needsInputsMode (StopBefore _) = True
493 needsInputsMode DoMake = True
494 needsInputsMode _ = False
495
496 -- True if we are going to attempt to link in this mode.
497 -- (we might not actually link, depending on the GhcLink flag)
498 isLinkMode :: PostLoadMode -> Bool
499 isLinkMode (StopBefore StopLn) = True
500 isLinkMode DoMake = True
501 isLinkMode DoInteractive = True
502 isLinkMode (DoEval _) = True
503 isLinkMode _ = False
504
505 isCompManagerMode :: PostLoadMode -> Bool
506 isCompManagerMode DoMake = True
507 isCompManagerMode DoInteractive = True
508 isCompManagerMode (DoEval _) = True
509 isCompManagerMode _ = False
510
511 -- -----------------------------------------------------------------------------
512 -- Parsing the mode flag
513
514 parseModeFlags :: [Located String]
515 -> IO (Mode,
516 [Located String],
517 [Located String])
518 parseModeFlags args = do
519 let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
520 runCmdLine (processArgs mode_flags args)
521 (Nothing, [], [])
522 mode = case mModeFlag of
523 Nothing -> doMakeMode
524 Just (m, _) -> m
525
526 -- See Note [Handling errors when parsing commandline flags]
527 unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
528 map (("on the commandline", )) $ map unLoc errs1 ++ errs2
529
530 return (mode, flags' ++ leftover, warns)
531
532 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
533 -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
534 -- so we collect the new ones and return them.
535
536 mode_flags :: [Flag ModeM]
537 mode_flags =
538 [ ------- help / version ----------------------------------------------
539 defFlag "?" (PassFlag (setMode showGhcUsageMode))
540 , defFlag "-help" (PassFlag (setMode showGhcUsageMode))
541 , defFlag "V" (PassFlag (setMode showVersionMode))
542 , defFlag "-version" (PassFlag (setMode showVersionMode))
543 , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
544 , defFlag "-info" (PassFlag (setMode showInfoMode))
545 , defFlag "-show-options" (PassFlag (setMode showOptionsMode))
546 , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
547 , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
548 , defFlag "-show-packages" (PassFlag (setMode showPackagesMode))
549 ] ++
550 [ defFlag k' (PassFlag (setMode (printSetting k)))
551 | k <- ["Project version",
552 "Project Git commit id",
553 "Booter version",
554 "Stage",
555 "Build platform",
556 "Host platform",
557 "Target platform",
558 "Have interpreter",
559 "Object splitting supported",
560 "Have native code generator",
561 "Support SMP",
562 "Unregisterised",
563 "Tables next to code",
564 "RTS ways",
565 "Leading underscore",
566 "Debug on",
567 "LibDir",
568 "Global Package DB",
569 "C compiler flags",
570 "Gcc Linker flags",
571 "Ld Linker flags"],
572 let k' = "-print-" ++ map (replaceSpace . toLower) k
573 replaceSpace ' ' = '-'
574 replaceSpace c = c
575 ] ++
576 ------- interfaces ----------------------------------------------------
577 [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
578 "--show-iface"))
579
580 ------- primary modes ------------------------------------------------
581 , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
582 addFlag "-no-link" f))
583 , defFlag "M" (PassFlag (setMode doMkDependHSMode))
584 , defFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
585 , defFlag "C" (PassFlag (setMode (stopBeforeMode HCc)))
586 , defFlag "S" (PassFlag (setMode (stopBeforeMode (As False))))
587 , defFlag "-make" (PassFlag (setMode doMakeMode))
588 , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
589 , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
590 , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
591 ]
592
593 setMode :: Mode -> String -> EwM ModeM ()
594 setMode newMode newFlag = liftEwM $ do
595 (mModeFlag, errs, flags') <- getCmdLineState
596 let (modeFlag', errs') =
597 case mModeFlag of
598 Nothing -> ((newMode, newFlag), errs)
599 Just (oldMode, oldFlag) ->
600 case (oldMode, newMode) of
601 -- -c/--make are allowed together, and mean --make -no-link
602 _ | isStopLnMode oldMode && isDoMakeMode newMode
603 || isStopLnMode newMode && isDoMakeMode oldMode ->
604 ((doMakeMode, "--make"), [])
605
606 -- If we have both --help and --interactive then we
607 -- want showGhciUsage
608 _ | isShowGhcUsageMode oldMode &&
609 isDoInteractiveMode newMode ->
610 ((showGhciUsageMode, oldFlag), [])
611 | isShowGhcUsageMode newMode &&
612 isDoInteractiveMode oldMode ->
613 ((showGhciUsageMode, newFlag), [])
614 -- Otherwise, --help/--version/--numeric-version always win
615 | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
616 | isDominantFlag newMode -> ((newMode, newFlag), [])
617 -- We need to accumulate eval flags like "-e foo -e bar"
618 (Right (Right (DoEval esOld)),
619 Right (Right (DoEval [eNew]))) ->
620 ((Right (Right (DoEval (eNew : esOld))), oldFlag),
621 errs)
622 -- Saying e.g. --interactive --interactive is OK
623 _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
624
625 -- --interactive and --show-options are used together
626 (Right (Right DoInteractive), Left (ShowOptions _)) ->
627 ((Left (ShowOptions True),
628 "--interactive --show-options"), errs)
629 (Left (ShowOptions _), (Right (Right DoInteractive))) ->
630 ((Left (ShowOptions True),
631 "--show-options --interactive"), errs)
632 -- Otherwise, complain
633 _ -> let err = flagMismatchErr oldFlag newFlag
634 in ((oldMode, oldFlag), err : errs)
635 putCmdLineState (Just modeFlag', errs', flags')
636 where isDominantFlag f = isShowGhcUsageMode f ||
637 isShowGhciUsageMode f ||
638 isShowVersionMode f ||
639 isShowNumVersionMode f
640
641 flagMismatchErr :: String -> String -> String
642 flagMismatchErr oldFlag newFlag
643 = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
644
645 addFlag :: String -> String -> EwM ModeM ()
646 addFlag s flag = liftEwM $ do
647 (m, e, flags') <- getCmdLineState
648 putCmdLineState (m, e, mkGeneralLocated loc s : flags')
649 where loc = "addFlag by " ++ flag ++ " on the commandline"
650
651 -- ----------------------------------------------------------------------------
652 -- Run --make mode
653
654 doMake :: [(String,Maybe Phase)] -> Ghc ()
655 doMake srcs = do
656 let (hs_srcs, non_hs_srcs) = partition haskellish srcs
657
658 haskellish (f,Nothing) =
659 looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
660 haskellish (_,Just phase) =
661 phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm
662 , StopLn]
663
664 hsc_env <- GHC.getSession
665
666 -- if we have no haskell sources from which to do a dependency
667 -- analysis, then just do one-shot compilation and/or linking.
668 -- This means that "ghc Foo.o Bar.o -o baz" links the program as
669 -- we expect.
670 if (null hs_srcs)
671 then liftIO (oneShot hsc_env StopLn srcs)
672 else do
673
674 o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
675 non_hs_srcs
676 dflags <- GHC.getSessionDynFlags
677 let dflags' = dflags { ldInputs = map (FileOption "") o_files
678 ++ ldInputs dflags }
679 _ <- GHC.setSessionDynFlags dflags'
680
681 targets <- mapM (uncurry GHC.guessTarget) hs_srcs
682 GHC.setTargets targets
683 ok_flag <- GHC.load LoadAllTargets
684
685 when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
686 return ()
687
688
689 -- ---------------------------------------------------------------------------
690 -- --show-iface mode
691
692 doShowIface :: DynFlags -> FilePath -> IO ()
693 doShowIface dflags file = do
694 hsc_env <- newHscEnv dflags
695 showIface hsc_env file
696
697 -- ---------------------------------------------------------------------------
698 -- Various banners and verbosity output.
699
700 showBanner :: PostLoadMode -> DynFlags -> IO ()
701 showBanner _postLoadMode dflags = do
702 let verb = verbosity dflags
703
704 #ifdef GHCI
705 -- Show the GHCi banner
706 when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
707 #endif
708
709 -- Display details of the configuration in verbose mode
710 when (verb >= 2) $
711 do hPutStr stderr "Glasgow Haskell Compiler, Version "
712 hPutStr stderr cProjectVersion
713 hPutStr stderr ", stage "
714 hPutStr stderr cStage
715 hPutStr stderr " booted by GHC version "
716 hPutStrLn stderr cBooterVersion
717
718 -- We print out a Read-friendly string, but a prettier one than the
719 -- Show instance gives us
720 showInfo :: DynFlags -> IO ()
721 showInfo dflags = do
722 let sq x = " [" ++ x ++ "\n ]"
723 putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
724
725 showSupportedExtensions :: IO ()
726 showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
727
728 showVersion :: IO ()
729 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
730
731 showOptions :: Bool -> IO ()
732 showOptions isInteractive = putStr (unlines availableOptions)
733 where
734 availableOptions = concat [
735 flagsForCompletion isInteractive,
736 map ('-':) (concat [
737 getFlagNames mode_flags
738 , (filterUnwantedStatic . getFlagNames $ flagsStatic)
739 , flagsStaticNames
740 ])
741 ]
742 getFlagNames opts = map flagName opts
743 -- this is a hack to get rid of two unwanted entries that get listed
744 -- as static flags. Hopefully this hack will disappear one day together
745 -- with static flags
746 filterUnwantedStatic = filter (`notElem`["f", "fno-"])
747
748 showGhcUsage :: DynFlags -> IO ()
749 showGhcUsage = showUsage False
750
751 showGhciUsage :: DynFlags -> IO ()
752 showGhciUsage = showUsage True
753
754 showUsage :: Bool -> DynFlags -> IO ()
755 showUsage ghci dflags = do
756 let usage_path = if ghci then ghciUsagePath dflags
757 else ghcUsagePath dflags
758 usage <- readFile usage_path
759 dump usage
760 where
761 dump "" = return ()
762 dump ('$':'$':s) = putStr progName >> dump s
763 dump (c:s) = putChar c >> dump s
764
765 dumpFinalStats :: DynFlags -> IO ()
766 dumpFinalStats dflags =
767 when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
768
769 dumpFastStringStats :: DynFlags -> IO ()
770 dumpFastStringStats dflags = do
771 buckets <- getFastStringTable
772 let (entries, longest, has_z) = countFS 0 0 0 buckets
773 msg = text "FastString stats:" $$
774 nest 4 (vcat [text "size: " <+> int (length buckets),
775 text "entries: " <+> int entries,
776 text "longest chain: " <+> int longest,
777 text "has z-encoding: " <+> (has_z `pcntOf` entries)
778 ])
779 -- we usually get more "has z-encoding" than "z-encoded", because
780 -- when we z-encode a string it might hash to the exact same string,
781 -- which will is not counted as "z-encoded". Only strings whose
782 -- Z-encoding is different from the original string are counted in
783 -- the "z-encoded" total.
784 putMsg dflags msg
785 where
786 x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
787
788 countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
789 countFS entries longest has_z [] = (entries, longest, has_z)
790 countFS entries longest has_z (b:bs) =
791 let
792 len = length b
793 longest' = max len longest
794 entries' = entries + len
795 has_zs = length (filter hasZEncoding b)
796 in
797 countFS entries' longest' (has_z + has_zs) bs
798
799 showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
800 showPackages dflags = putStrLn (showSDoc dflags (pprPackages dflags))
801 dumpPackages dflags = putMsg dflags (pprPackages dflags)
802 dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)
803
804 -- -----------------------------------------------------------------------------
805 -- ABI hash support
806
807 {-
808 ghc --abi-hash Data.Foo System.Bar
809
810 Generates a combined hash of the ABI for modules Data.Foo and
811 System.Bar. The modules must already be compiled, and appropriate -i
812 options may be necessary in order to find the .hi files.
813
814 This is used by Cabal for generating the InstalledPackageId for a
815 package. The InstalledPackageId must change when the visible ABI of
816 the package chagnes, so during registration Cabal calls ghc --abi-hash
817 to get a hash of the package's ABI.
818 -}
819
820 -- | Print ABI hash of input modules.
821 --
822 -- The resulting hash is the MD5 of the GHC version used (Trac #5328,
823 -- see 'hiVersion') and of the existing ABI hash from each module (see
824 -- 'mi_mod_hash').
825 abiHash :: [String] -- ^ List of module names
826 -> Ghc ()
827 abiHash strs = do
828 hsc_env <- getSession
829 let dflags = hsc_dflags hsc_env
830
831 liftIO $ do
832
833 let find_it str = do
834 let modname = mkModuleName str
835 r <- findImportedModule hsc_env modname Nothing
836 case r of
837 Found _ m -> return m
838 _error -> throwGhcException $ CmdLineError $ showSDoc dflags $
839 cannotFindInterface dflags modname r
840
841 mods <- mapM find_it strs
842
843 let get_iface modl = loadUserInterface False (text "abiHash") modl
844 ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
845
846 bh <- openBinMem (3*1024) -- just less than a block
847 put_ bh hiVersion
848 -- package hashes change when the compiler version changes (for now)
849 -- see #5328
850 mapM_ (put_ bh . mi_mod_hash) ifaces
851 f <- fingerprintBinMem bh
852
853 putStrLn (showPpr dflags f)
854
855 -- -----------------------------------------------------------------------------
856 -- Util
857
858 unknownFlagsErr :: [String] -> a
859 unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
860 where
861 oneError f =
862 "unrecognised flag: " ++ f ++ "\n" ++
863 (case fuzzyMatch f (nub allFlags) of
864 [] -> ""
865 suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
866
867 {- Note [-Bsymbolic and hooks]
868 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
869 -Bsymbolic is a flag that prevents the binding of references to global
870 symbols to symbols outside the shared library being compiled (see `man
871 ld`). When dynamically linking, we don't use -Bsymbolic on the RTS
872 package: that is because we want hooks to be overridden by the user,
873 we don't want to constrain them to the RTS package.
874
875 Unfortunately this seems to have broken somehow on OS X: as a result,
876 defaultHooks (in hschooks.c) is not called, which does not initialize
877 the GC stats. As a result, this breaks things like `:set +s` in GHCi
878 (#8754). As a hacky workaround, we instead call 'defaultHooks'
879 directly to initalize the flags in the RTS.
880
881 A byproduct of this, I believe, is that hooks are likely broken on OS
882 X when dynamically linking. But this probably doesn't affect most
883 people since we're linking GHC dynamically, but most things themselves
884 link statically.
885 -}
886
887 foreign import ccall safe "initGCStatistics"
888 initGCStatistics :: IO ()