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