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