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