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