never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE LambdaCase #-}
3 {-# LANGUAGE NondecreasingIndentation #-}
4 {-# LANGUAGE TupleSections #-}
5 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
6
7 -----------------------------------------------------------------------------
8 --
9 -- GHC Driver program
10 --
11 -- (c) The University of Glasgow 2005
12 --
13 -----------------------------------------------------------------------------
14
15 module Main (main) where
16
17 -- The official GHC API
18 import qualified GHC
19 import GHC (parseTargetFiles, Ghc, GhcMonad(..), Backend (..),
20 LoadHowMuch(..) )
21
22 import GHC.Driver.CmdLine
23 import GHC.Driver.Env
24 import GHC.Driver.Errors
25 import GHC.Driver.Phases
26 import GHC.Driver.Session
27 import GHC.Driver.Ppr
28 import GHC.Driver.Pipeline ( oneShot, compileFile )
29 import GHC.Driver.MakeFile ( doMkDependHS )
30 import GHC.Driver.Backpack ( doBackpack )
31 import GHC.Driver.Plugins
32 import GHC.Driver.Config.Finder (initFinderOpts)
33 import GHC.Driver.Config.Logger (initLogFlags)
34 import GHC.Driver.Config.Diagnostic
35
36 import GHC.Platform
37 import GHC.Platform.Ways
38 import GHC.Platform.Host
39
40 #if defined(HAVE_INTERNAL_INTERPRETER)
41 import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
42 #endif
43
44 import GHC.Runtime.Loader ( loadFrontendPlugin )
45
46 import GHC.Unit.Module ( ModuleName, mkModuleName )
47 import GHC.Unit.Module.ModIface
48 import GHC.Unit.State ( pprUnits, pprUnitsSimple )
49 import GHC.Unit.Finder ( findImportedModule, FindResult(..) )
50 import GHC.Unit.Types ( IsBootInterface(..) )
51
52 import GHC.Types.Basic ( failed )
53 import GHC.Types.SrcLoc
54 import GHC.Types.SourceError
55 import GHC.Types.Unique.Supply
56 import GHC.Types.PkgQual
57
58 import GHC.Utils.Error
59 import GHC.Utils.Misc
60 import GHC.Utils.Panic
61 import GHC.Utils.Outputable as Outputable
62 import GHC.Utils.Monad ( liftIO, mapMaybeM )
63 import GHC.Utils.Binary ( openBinMem, put_ )
64 import GHC.Utils.Logger
65
66 import GHC.Settings.Config
67 import GHC.Settings.Constants
68 import GHC.Settings.IO
69
70 import GHC.HandleEncoding
71 import GHC.Data.FastString
72 import GHC.SysTools.BaseDir
73
74 import GHC.Iface.Load
75 import GHC.Iface.Recomp.Binary ( fingerprintBinMem )
76
77 import GHC.Tc.Utils.Monad ( initIfaceCheck )
78
79 -- Standard Haskell libraries
80 import System.IO
81 import System.Environment
82 import System.Exit
83 import Control.Monad
84 import Control.Monad.Trans.Class
85 import Control.Monad.Trans.Except (throwE, runExceptT)
86 import Data.Char
87 import Data.List ( isPrefixOf, partition, intercalate )
88 import qualified Data.Set as Set
89 import Data.Maybe
90 import Prelude
91
92 -----------------------------------------------------------------------------
93 -- ToDo:
94
95 -- time commands when run with -v
96 -- user ways
97 -- Win32 support: proper signal handling
98 -- reading the package configuration file is too slow
99 -- -K<size>
100
101 -----------------------------------------------------------------------------
102 -- GHC's command-line interface
103
104 main :: IO ()
105 main = do
106 hSetBuffering stdout LineBuffering
107 hSetBuffering stderr LineBuffering
108
109 configureHandleEncoding
110 GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
111 -- 1. extract the -B flag from the args
112 argv0 <- getArgs
113
114 let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
115 mbMinusB | null minusB_args = Nothing
116 | otherwise = Just (drop 2 (last minusB_args))
117
118 let argv2 = map (mkGeneralLocated "on the commandline") argv1
119
120 -- 2. Parse the "mode" flags (--make, --interactive etc.)
121 (mode, argv3, flagWarnings) <- parseModeFlags argv2
122
123 -- If all we want to do is something like showing the version number
124 -- then do it now, before we start a GHC session etc. This makes
125 -- getting basic information much more resilient.
126
127 -- In particular, if we wait until later before giving the version
128 -- number then bootstrapping gets confused, as it tries to find out
129 -- what version of GHC it's using before package.conf exists, so
130 -- starting the session fails.
131 case mode of
132 Left preStartupMode ->
133 do case preStartupMode of
134 ShowSupportedExtensions -> showSupportedExtensions mbMinusB
135 ShowVersion -> showVersion
136 ShowNumVersion -> putStrLn cProjectVersion
137 ShowOptions isInteractive -> showOptions isInteractive
138 Right postStartupMode ->
139 -- start our GHC session
140 GHC.runGhc mbMinusB $ do
141
142 dflags <- GHC.getSessionDynFlags
143
144 case postStartupMode of
145 Left preLoadMode ->
146 liftIO $ do
147 case preLoadMode of
148 ShowInfo -> showInfo dflags
149 ShowGhcUsage -> showGhcUsage dflags
150 ShowGhciUsage -> showGhciUsage dflags
151 PrintWithDynFlags f -> putStrLn (f dflags)
152 Right postLoadMode ->
153 main' postLoadMode dflags argv3 flagWarnings
154
155 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
156 -> Ghc ()
157 main' postLoadMode dflags0 args flagWarnings = do
158 let args' = case postLoadMode of
159 DoRun -> takeWhile (\arg -> unLoc arg /= "--") args
160 _ -> args
161
162 -- set the default GhcMode, backend and GhcLink. The backend
163 -- can be further adjusted on a module by module basis, using only
164 -- the -fllvm and -fasm flags. If the default backend is not
165 -- LLVM or NCG, -fllvm and -fasm have no effect.
166 let dflt_backend = backend dflags0
167 (mode, bcknd, link)
168 = case postLoadMode of
169 DoInteractive -> (CompManager, Interpreter, LinkInMemory)
170 DoEval _ -> (CompManager, Interpreter, LinkInMemory)
171 DoRun -> (CompManager, Interpreter, LinkInMemory)
172 DoMake -> (CompManager, dflt_backend, LinkBinary)
173 DoBackpack -> (CompManager, dflt_backend, LinkBinary)
174 DoMkDependHS -> (MkDepend, dflt_backend, LinkBinary)
175 DoAbiHash -> (OneShot, dflt_backend, LinkBinary)
176 _ -> (OneShot, dflt_backend, LinkBinary)
177
178 let dflags1 = dflags0{ ghcMode = mode,
179 backend = bcknd,
180 ghcLink = link,
181 verbosity = case postLoadMode of
182 DoEval _ -> 0
183 DoRun -> 0
184 _other -> 1
185 }
186
187 -- turn on -fimplicit-import-qualified for GHCi now, so that it
188 -- can be overridden from the command-line
189 -- XXX: this should really be in the interactive DynFlags, but
190 -- we don't set that until later in interactiveUI
191 -- We also set -fignore-optim-changes and -fignore-hpc-changes,
192 -- which are program-level options. Again, this doesn't really
193 -- feel like the right place to handle this, but we don't have
194 -- a great story for the moment.
195 dflags2 | DoInteractive <- postLoadMode = def_ghci_flags
196 | DoEval _ <- postLoadMode = def_ghci_flags
197 | DoRun <- postLoadMode = def_ghci_flags
198 | otherwise = dflags1
199 where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified
200 `gopt_set` Opt_IgnoreOptimChanges
201 `gopt_set` Opt_IgnoreHpcChanges
202
203 logger1 <- getLogger
204 let logger2 = setLogFlags logger1 (initLogFlags dflags2)
205
206 -- The rest of the arguments are "dynamic"
207 -- Leftover ones are presumably files
208 (dflags3, fileish_args, dynamicFlagWarnings) <-
209 GHC.parseDynamicFlags logger2 dflags2 args'
210
211 let dflags4 = case bcknd of
212 Interpreter | not (gopt Opt_ExternalInterpreter dflags3) ->
213 let platform = targetPlatform dflags3
214 dflags3a = dflags3 { targetWays_ = hostFullWays }
215 dflags3b = foldl gopt_set dflags3a
216 $ concatMap (wayGeneralFlags platform)
217 hostFullWays
218 dflags3c = foldl gopt_unset dflags3b
219 $ concatMap (wayUnsetGeneralFlags platform)
220 hostFullWays
221 in dflags3c
222 _ ->
223 dflags3
224
225 let logger4 = setLogFlags logger2 (initLogFlags dflags4)
226
227 GHC.prettyPrintGhcErrors logger4 $ do
228
229 let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
230
231 handleSourceError (\e -> do
232 GHC.printException e
233 liftIO $ exitWith (ExitFailure 1)) $ do
234 liftIO $ handleFlagWarnings logger4 (initDiagOpts dflags4) flagWarnings'
235
236 liftIO $ showBanner postLoadMode dflags4
237
238 let (dflags5, srcs, objs) = parseTargetFiles dflags4 (map unLoc fileish_args)
239
240 -- we've finished manipulating the DynFlags, update the session
241 _ <- GHC.setSessionDynFlags dflags5
242 dflags6 <- GHC.getSessionDynFlags
243 hsc_env <- GHC.getSession
244 logger <- getLogger
245
246 ---------------- Display configuration -----------
247 case verbosity dflags6 of
248 v | v == 4 -> liftIO $ dumpUnitsSimple hsc_env
249 | v >= 5 -> liftIO $ dumpUnits hsc_env
250 | otherwise -> return ()
251
252 liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)
253 ---------------- Final sanity checking -----------
254 liftIO $ checkOptions postLoadMode dflags6 srcs objs
255
256 ---------------- Do the business -----------
257 handleSourceError (\e -> do
258 GHC.printException e
259 liftIO $ exitWith (ExitFailure 1)) $ do
260 case postLoadMode of
261 ShowInterface f -> liftIO $ showIface logger
262 (hsc_dflags hsc_env)
263 (hsc_units hsc_env)
264 (hsc_NC hsc_env)
265 f
266 DoMake -> doMake srcs
267 DoMkDependHS -> doMkDependHS (map fst srcs)
268 StopBefore p -> liftIO (oneShot hsc_env p srcs)
269 DoInteractive -> ghciUI srcs Nothing
270 DoEval exprs -> ghciUI srcs $ Just $ reverse exprs
271 DoRun -> doRun srcs args
272 DoAbiHash -> abiHash (map fst srcs)
273 ShowPackages -> liftIO $ showUnits hsc_env
274 DoFrontend f -> doFrontend f srcs
275 DoBackpack -> doBackpack (map fst srcs)
276
277 liftIO $ dumpFinalStats logger
278
279 doRun :: [(FilePath, Maybe Phase)] -> [Located String] -> Ghc ()
280 doRun srcs args = do
281 dflags <- getDynFlags
282 let mainFun = fromMaybe "main" (mainFunIs dflags)
283 ghciUI srcs (Just ["System.Environment.withArgs " ++ show args' ++ " (Control.Monad.void " ++ mainFun ++ ")"])
284 where
285 args' = drop 1 $ dropWhile (/= "--") $ map unLoc args
286
287 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
288 #if !defined(HAVE_INTERNAL_INTERPRETER)
289 ghciUI _ _ =
290 throwGhcException (CmdLineError "not built for interactive use")
291 #else
292 ghciUI srcs maybe_expr = interactiveUI defaultGhciSettings srcs maybe_expr
293 #endif
294
295
296 -- -----------------------------------------------------------------------------
297 -- Option sanity checks
298
299 -- | Ensure sanity of options.
300 --
301 -- Throws 'UsageError' or 'CmdLineError' if not.
302 checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
303 -- Final sanity checking before kicking off a compilation (pipeline).
304 checkOptions mode dflags srcs objs = do
305 -- Complain about any unknown flags
306 let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
307 when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
308
309 when (not (Set.null (rtsWays (ways dflags)))
310 && isInterpretiveMode mode) $
311 hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
312
313 -- -prof and --interactive are not a good combination
314 when ((fullWays (ways dflags) /= hostFullWays)
315 && isInterpretiveMode mode
316 && not (gopt Opt_ExternalInterpreter dflags)) $
317 do throwGhcException (UsageError
318 "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
319 -- -ohi sanity check
320 if (isJust (outputHi dflags) &&
321 (isCompManagerMode mode || srcs `lengthExceeds` 1))
322 then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
323 else do
324
325 if (isJust (dynOutputHi dflags) &&
326 (isCompManagerMode mode || srcs `lengthExceeds` 1))
327 then throwGhcException (UsageError "-dynohi can only be used when compiling a single source file")
328 else do
329
330 -- -o sanity checking
331 if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
332 && not (isLinkMode mode))
333 then throwGhcException (UsageError "can't apply -o to multiple source files")
334 else do
335
336 let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
337
338 when (not_linking && not (null objs)) $
339 hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
340
341 -- Check that there are some input files
342 -- (except in the interactive case)
343 if null srcs && (null objs || not_linking) && needsInputsMode mode
344 then throwGhcException (UsageError "no input files")
345 else do
346
347 case mode of
348 StopBefore StopC | backend dflags /= ViaC
349 -> throwGhcException $ UsageError $
350 "the option -C is only available with an unregisterised GHC"
351 StopBefore StopAs | ghcLink dflags == NoLink
352 -> throwGhcException $ UsageError $
353 "the options -S and -fno-code are incompatible. Please omit -S"
354
355 _ -> return ()
356
357 -- Verify that output files point somewhere sensible.
358 verifyOutputFiles dflags
359
360 -- Compiler output options
361
362 -- Called to verify that the output files point somewhere valid.
363 --
364 -- The assumption is that the directory portion of these output
365 -- options will have to exist by the time 'verifyOutputFiles'
366 -- is invoked.
367 --
368 -- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
369 -- they don't exist, so don't check for those here (#2278).
370 verifyOutputFiles :: DynFlags -> IO ()
371 verifyOutputFiles dflags = do
372 let ofile = outputFile dflags
373 when (isJust ofile) $ do
374 let fn = fromJust ofile
375 flg <- doesDirNameExist fn
376 when (not flg) (nonExistentDir "-o" fn)
377 let ohi = outputHi dflags
378 when (isJust ohi) $ do
379 let hi = fromJust ohi
380 flg <- doesDirNameExist hi
381 when (not flg) (nonExistentDir "-ohi" hi)
382 where
383 nonExistentDir flg dir =
384 throwGhcException (CmdLineError ("error: directory portion of " ++
385 show dir ++ " does not exist (used with " ++
386 show flg ++ " option.)"))
387
388 -----------------------------------------------------------------------------
389 -- GHC modes of operation
390
391 type Mode = Either PreStartupMode PostStartupMode
392 type PostStartupMode = Either PreLoadMode PostLoadMode
393
394 data PreStartupMode
395 = ShowVersion -- ghc -V/--version
396 | ShowNumVersion -- ghc --numeric-version
397 | ShowSupportedExtensions -- ghc --supported-extensions
398 | ShowOptions Bool {- isInteractive -} -- ghc --show-options
399
400 showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
401 showVersionMode = mkPreStartupMode ShowVersion
402 showNumVersionMode = mkPreStartupMode ShowNumVersion
403 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
404 showOptionsMode = mkPreStartupMode (ShowOptions False)
405
406 mkPreStartupMode :: PreStartupMode -> Mode
407 mkPreStartupMode = Left
408
409 isShowVersionMode :: Mode -> Bool
410 isShowVersionMode (Left ShowVersion) = True
411 isShowVersionMode _ = False
412
413 isShowNumVersionMode :: Mode -> Bool
414 isShowNumVersionMode (Left ShowNumVersion) = True
415 isShowNumVersionMode _ = False
416
417 data PreLoadMode
418 = ShowGhcUsage -- ghc -?
419 | ShowGhciUsage -- ghci -?
420 | ShowInfo -- ghc --info
421 | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
422
423 showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
424 showGhcUsageMode = mkPreLoadMode ShowGhcUsage
425 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
426 showInfoMode = mkPreLoadMode ShowInfo
427
428 printSetting :: String -> Mode
429 printSetting k = mkPreLoadMode (PrintWithDynFlags f)
430 where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
431 $ lookup k (compilerInfo dflags)
432
433 mkPreLoadMode :: PreLoadMode -> Mode
434 mkPreLoadMode = Right . Left
435
436 isShowGhcUsageMode :: Mode -> Bool
437 isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
438 isShowGhcUsageMode _ = False
439
440 isShowGhciUsageMode :: Mode -> Bool
441 isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
442 isShowGhciUsageMode _ = False
443
444 data PostLoadMode
445 = ShowInterface FilePath -- ghc --show-iface
446 | DoMkDependHS -- ghc -M
447 | StopBefore StopPhase -- ghc -E | -C | -S
448 -- StopBefore StopLn is the default
449 | DoMake -- ghc --make
450 | DoBackpack -- ghc --backpack foo.bkp
451 | DoInteractive -- ghc --interactive
452 | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
453 | DoRun -- ghc --run
454 | DoAbiHash -- ghc --abi-hash
455 | ShowPackages -- ghc --show-packages
456 | DoFrontend ModuleName -- ghc --frontend Plugin.Module
457
458 doMkDependHSMode, doMakeMode, doInteractiveMode, doRunMode,
459 doAbiHashMode, showUnitsMode :: Mode
460 doMkDependHSMode = mkPostLoadMode DoMkDependHS
461 doMakeMode = mkPostLoadMode DoMake
462 doInteractiveMode = mkPostLoadMode DoInteractive
463 doRunMode = mkPostLoadMode DoRun
464 doAbiHashMode = mkPostLoadMode DoAbiHash
465 showUnitsMode = mkPostLoadMode ShowPackages
466
467 showInterfaceMode :: FilePath -> Mode
468 showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
469
470 stopBeforeMode :: StopPhase -> Mode
471 stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
472
473 doEvalMode :: String -> Mode
474 doEvalMode str = mkPostLoadMode (DoEval [str])
475
476 doFrontendMode :: String -> Mode
477 doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
478
479 doBackpackMode :: Mode
480 doBackpackMode = mkPostLoadMode DoBackpack
481
482 mkPostLoadMode :: PostLoadMode -> Mode
483 mkPostLoadMode = Right . Right
484
485 isDoInteractiveMode :: Mode -> Bool
486 isDoInteractiveMode (Right (Right DoInteractive)) = True
487 isDoInteractiveMode _ = False
488
489 isStopLnMode :: Mode -> Bool
490 isStopLnMode (Right (Right (StopBefore NoStop))) = True
491 isStopLnMode _ = False
492
493 isDoMakeMode :: Mode -> Bool
494 isDoMakeMode (Right (Right DoMake)) = True
495 isDoMakeMode _ = False
496
497 isDoEvalMode :: Mode -> Bool
498 isDoEvalMode (Right (Right (DoEval _))) = True
499 isDoEvalMode _ = False
500
501 #if defined(HAVE_INTERNAL_INTERPRETER)
502 isInteractiveMode :: PostLoadMode -> Bool
503 isInteractiveMode DoInteractive = True
504 isInteractiveMode _ = False
505 #endif
506
507 -- isInterpretiveMode: byte-code compiler involved
508 isInterpretiveMode :: PostLoadMode -> Bool
509 isInterpretiveMode DoInteractive = True
510 isInterpretiveMode (DoEval _) = True
511 isInterpretiveMode _ = False
512
513 needsInputsMode :: PostLoadMode -> Bool
514 needsInputsMode DoMkDependHS = True
515 needsInputsMode (StopBefore _) = True
516 needsInputsMode DoMake = True
517 needsInputsMode _ = False
518
519 -- True if we are going to attempt to link in this mode.
520 -- (we might not actually link, depending on the GhcLink flag)
521 isLinkMode :: PostLoadMode -> Bool
522 isLinkMode (StopBefore NoStop) = True
523 isLinkMode DoMake = True
524 isLinkMode DoRun = True
525 isLinkMode DoInteractive = True
526 isLinkMode (DoEval _) = True
527 isLinkMode _ = False
528
529 isCompManagerMode :: PostLoadMode -> Bool
530 isCompManagerMode DoRun = True
531 isCompManagerMode DoMake = True
532 isCompManagerMode DoInteractive = True
533 isCompManagerMode (DoEval _) = True
534 isCompManagerMode _ = False
535
536 -- -----------------------------------------------------------------------------
537 -- Parsing the mode flag
538
539 parseModeFlags :: [Located String]
540 -> IO (Mode,
541 [Located String],
542 [Warn])
543 parseModeFlags args = do
544 let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
545 runCmdLine (processArgs mode_flags args)
546 (Nothing, [], [])
547 mode = case mModeFlag of
548 Nothing -> doMakeMode
549 Just (m, _) -> m
550
551 -- See Note [Handling errors when parsing commandline flags]
552 unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
553 map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
554
555 return (mode, flags' ++ leftover, warns)
556
557 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
558 -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
559 -- so we collect the new ones and return them.
560
561 mode_flags :: [Flag ModeM]
562 mode_flags =
563 [ ------- help / version ----------------------------------------------
564 defFlag "?" (PassFlag (setMode showGhcUsageMode))
565 , defFlag "-help" (PassFlag (setMode showGhcUsageMode))
566 , defFlag "V" (PassFlag (setMode showVersionMode))
567 , defFlag "-version" (PassFlag (setMode showVersionMode))
568 , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
569 , defFlag "-info" (PassFlag (setMode showInfoMode))
570 , defFlag "-show-options" (PassFlag (setMode showOptionsMode))
571 , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
572 , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
573 , defFlag "-show-packages" (PassFlag (setMode showUnitsMode))
574 ] ++
575 [ defFlag k' (PassFlag (setMode (printSetting k)))
576 | k <- ["Project version",
577 "Project Git commit id",
578 "Booter version",
579 "Stage",
580 "Build platform",
581 "Host platform",
582 "Target platform",
583 "Have interpreter",
584 "Object splitting supported",
585 "Have native code generator",
586 "Support SMP",
587 "Unregisterised",
588 "Tables next to code",
589 "RTS ways",
590 "Leading underscore",
591 "Debug on",
592 "LibDir",
593 "Global Package DB",
594 "C compiler flags",
595 "C compiler link flags",
596 "ld flags"],
597 let k' = "-print-" ++ map (replaceSpace . toLower) k
598 replaceSpace ' ' = '-'
599 replaceSpace c = c
600 ] ++
601 ------- interfaces ----------------------------------------------------
602 [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
603 "--show-iface"))
604
605 ------- primary modes ------------------------------------------------
606 , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode NoStop) f
607 addFlag "-no-link" f))
608 , defFlag "M" (PassFlag (setMode doMkDependHSMode))
609 , defFlag "E" (PassFlag (setMode (stopBeforeMode StopPreprocess )))
610 , defFlag "C" (PassFlag (setMode (stopBeforeMode StopC)))
611 , defFlag "S" (PassFlag (setMode (stopBeforeMode StopAs)))
612 , defFlag "-run" (PassFlag (setMode doRunMode))
613 , defFlag "-make" (PassFlag (setMode doMakeMode))
614 , defFlag "-backpack" (PassFlag (setMode doBackpackMode))
615 , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
616 , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
617 , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
618 , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))
619 ]
620
621 setMode :: Mode -> String -> EwM ModeM ()
622 setMode newMode newFlag = liftEwM $ do
623 (mModeFlag, errs, flags') <- getCmdLineState
624 let (modeFlag', errs') =
625 case mModeFlag of
626 Nothing -> ((newMode, newFlag), errs)
627 Just (oldMode, oldFlag) ->
628 case (oldMode, newMode) of
629 -- -c/--make are allowed together, and mean --make -no-link
630 _ | isStopLnMode oldMode && isDoMakeMode newMode
631 || isStopLnMode newMode && isDoMakeMode oldMode ->
632 ((doMakeMode, "--make"), [])
633
634 -- If we have both --help and --interactive then we
635 -- want showGhciUsage
636 _ | isShowGhcUsageMode oldMode &&
637 isDoInteractiveMode newMode ->
638 ((showGhciUsageMode, oldFlag), [])
639 | isShowGhcUsageMode newMode &&
640 isDoInteractiveMode oldMode ->
641 ((showGhciUsageMode, newFlag), [])
642
643 -- If we have both -e and --interactive then -e always wins
644 _ | isDoEvalMode oldMode &&
645 isDoInteractiveMode newMode ->
646 ((oldMode, oldFlag), [])
647 | isDoEvalMode newMode &&
648 isDoInteractiveMode oldMode ->
649 ((newMode, newFlag), [])
650
651 -- Otherwise, --help/--version/--numeric-version always win
652 | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
653 | isDominantFlag newMode -> ((newMode, newFlag), [])
654 -- We need to accumulate eval flags like "-e foo -e bar"
655 (Right (Right (DoEval esOld)),
656 Right (Right (DoEval [eNew]))) ->
657 ((Right (Right (DoEval (eNew : esOld))), oldFlag),
658 errs)
659 -- Saying e.g. --interactive --interactive is OK
660 _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
661
662 -- --interactive and --show-options are used together
663 (Right (Right DoInteractive), Left (ShowOptions _)) ->
664 ((Left (ShowOptions True),
665 "--interactive --show-options"), errs)
666 (Left (ShowOptions _), (Right (Right DoInteractive))) ->
667 ((Left (ShowOptions True),
668 "--show-options --interactive"), errs)
669 -- Otherwise, complain
670 _ -> let err = flagMismatchErr oldFlag newFlag
671 in ((oldMode, oldFlag), err : errs)
672 putCmdLineState (Just modeFlag', errs', flags')
673 where isDominantFlag f = isShowGhcUsageMode f ||
674 isShowGhciUsageMode f ||
675 isShowVersionMode f ||
676 isShowNumVersionMode f
677
678 flagMismatchErr :: String -> String -> String
679 flagMismatchErr oldFlag newFlag
680 = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
681
682 addFlag :: String -> String -> EwM ModeM ()
683 addFlag s flag = liftEwM $ do
684 (m, e, flags') <- getCmdLineState
685 putCmdLineState (m, e, mkGeneralLocated loc s : flags')
686 where loc = "addFlag by " ++ flag ++ " on the commandline"
687
688 -- ----------------------------------------------------------------------------
689 -- Run --make mode
690
691 doMake :: [(String,Maybe Phase)] -> Ghc ()
692 doMake srcs = do
693 let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
694
695 hsc_env <- GHC.getSession
696
697 -- if we have no haskell sources from which to do a dependency
698 -- analysis, then just do one-shot compilation and/or linking.
699 -- This means that "ghc Foo.o Bar.o -o baz" links the program as
700 -- we expect.
701 if (null hs_srcs)
702 then liftIO (oneShot hsc_env NoStop srcs)
703 else do
704
705 o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x)
706 non_hs_srcs
707 dflags <- GHC.getSessionDynFlags
708 let dflags' = dflags { ldInputs = map (FileOption "") o_files
709 ++ ldInputs dflags }
710 _ <- GHC.setSessionDynFlags dflags'
711
712 targets <- mapM (\(src, phase) -> GHC.guessTarget src Nothing phase) hs_srcs
713 GHC.setTargets targets
714 ok_flag <- GHC.load LoadAllTargets
715
716 when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
717 return ()
718
719
720 -- ---------------------------------------------------------------------------
721 -- Various banners and verbosity output.
722
723 showBanner :: PostLoadMode -> DynFlags -> IO ()
724 showBanner _postLoadMode dflags = do
725 let verb = verbosity dflags
726
727 #if defined(HAVE_INTERNAL_INTERPRETER)
728 -- Show the GHCi banner
729 when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
730 #endif
731
732 -- Display details of the configuration in verbose mode
733 when (verb >= 2) $
734 do hPutStr stderr "Glasgow Haskell Compiler, Version "
735 hPutStr stderr cProjectVersion
736 hPutStr stderr ", stage "
737 hPutStr stderr cStage
738 hPutStr stderr " booted by GHC version "
739 hPutStrLn stderr cBooterVersion
740
741 -- We print out a Read-friendly string, but a prettier one than the
742 -- Show instance gives us
743 showInfo :: DynFlags -> IO ()
744 showInfo dflags = do
745 let sq x = " [" ++ x ++ "\n ]"
746 putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
747
748 -- TODO use GHC.Utils.Error once that is disentangled from all the other GhcMonad stuff?
749 showSupportedExtensions :: Maybe String -> IO ()
750 showSupportedExtensions m_top_dir = do
751 res <- runExceptT $ do
752 top_dir <- lift (tryFindTopDir m_top_dir) >>= \case
753 Nothing -> throwE $ SettingsError_MissingData "Could not find the top directory, missing -B flag"
754 Just dir -> pure dir
755 initSettings top_dir
756 arch_os <- case res of
757 Right s -> pure $ platformArchOS $ sTargetPlatform s
758 Left (SettingsError_MissingData msg) -> do
759 hPutStrLn stderr $ "WARNING: " ++ show msg
760 hPutStrLn stderr $ "cannot know target platform so guessing target == host (native compiler)."
761 pure hostPlatformArchOS
762 Left (SettingsError_BadData msg) -> do
763 hPutStrLn stderr msg
764 exitWith $ ExitFailure 1
765 mapM_ putStrLn $ supportedLanguagesAndExtensions arch_os
766
767 showVersion :: IO ()
768 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
769
770 showOptions :: Bool -> IO ()
771 showOptions isInteractive = putStr (unlines availableOptions)
772 where
773 availableOptions = concat [
774 flagsForCompletion isInteractive,
775 map ('-':) (getFlagNames mode_flags)
776 ]
777 getFlagNames opts = map flagName opts
778
779 showGhcUsage :: DynFlags -> IO ()
780 showGhcUsage = showUsage False
781
782 showGhciUsage :: DynFlags -> IO ()
783 showGhciUsage = showUsage True
784
785 showUsage :: Bool -> DynFlags -> IO ()
786 showUsage ghci dflags = do
787 let usage_path = if ghci then ghciUsagePath dflags
788 else ghcUsagePath dflags
789 usage <- readFile usage_path
790 progName <- getProgName
791 dump progName usage
792 where
793 dump progName xs = case xs of
794 "" -> return ()
795 '$':'$':s -> putStr progName >> dump progName s
796 c:s -> putChar c >> dump progName s
797
798 dumpFinalStats :: Logger -> IO ()
799 dumpFinalStats logger = do
800 when (logHasDumpFlag logger Opt_D_faststring_stats) $ dumpFastStringStats logger
801
802 when (logHasDumpFlag logger Opt_D_dump_faststrings) $ do
803 fss <- getFastStringTable
804 let ppr_table = fmap ppr_segment (fss `zip` [0..])
805 ppr_segment (s,n) = hang (text "Segment" <+> int n) 2 (vcat (fmap ppr_bucket (s `zip` [0..])))
806 ppr_bucket (b,n) = hang (text "Bucket" <+> int n) 2 (vcat (fmap ftext b))
807 putDumpFileMaybe logger Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table)
808
809 dumpFastStringStats :: Logger -> IO ()
810 dumpFastStringStats logger = do
811 segments <- getFastStringTable
812 hasZ <- getFastStringZEncCounter
813 let buckets = concat segments
814 bucketsPerSegment = map length segments
815 entriesPerBucket = map length buckets
816 entries = sum entriesPerBucket
817 msg = text "FastString stats:" $$ nest 4 (vcat
818 [ text "segments: " <+> int (length segments)
819 , text "buckets: " <+> int (sum bucketsPerSegment)
820 , text "entries: " <+> int entries
821 , text "largest segment: " <+> int (maximum bucketsPerSegment)
822 , text "smallest segment: " <+> int (minimum bucketsPerSegment)
823 , text "longest bucket: " <+> int (maximum entriesPerBucket)
824 , text "has z-encoding: " <+> (hasZ `pcntOf` entries)
825 ])
826 -- we usually get more "has z-encoding" than "z-encoded", because
827 -- when we z-encode a string it might hash to the exact same string,
828 -- which is not counted as "z-encoded". Only strings whose
829 -- Z-encoding is different from the original string are counted in
830 -- the "z-encoded" total.
831 putMsg logger msg
832 where
833 x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
834
835 showUnits, dumpUnits, dumpUnitsSimple :: HscEnv -> IO ()
836 showUnits hsc_env = putStrLn (showSDoc (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env)))
837 dumpUnits hsc_env = putMsg (hsc_logger hsc_env) (pprUnits (hsc_units hsc_env))
838 dumpUnitsSimple hsc_env = putMsg (hsc_logger hsc_env) (pprUnitsSimple (hsc_units hsc_env))
839
840 -- -----------------------------------------------------------------------------
841 -- Frontend plugin support
842
843 doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
844 doFrontend modname srcs = do
845 hsc_env <- getSession
846 frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname
847 frontend frontend_plugin
848 (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs
849
850 -- -----------------------------------------------------------------------------
851 -- ABI hash support
852
853 {-
854 ghc --abi-hash Data.Foo System.Bar
855
856 Generates a combined hash of the ABI for modules Data.Foo and
857 System.Bar. The modules must already be compiled, and appropriate -i
858 options may be necessary in order to find the .hi files.
859
860 This is used by Cabal for generating the ComponentId for a
861 package. The ComponentId must change when the visible ABI of
862 the package changes, so during registration Cabal calls ghc --abi-hash
863 to get a hash of the package's ABI.
864 -}
865
866 -- | Print ABI hash of input modules.
867 --
868 -- The resulting hash is the MD5 of the GHC version used (#5328,
869 -- see 'hiVersion') and of the existing ABI hash from each module (see
870 -- 'mi_mod_hash').
871 abiHash :: [String] -- ^ List of module names
872 -> Ghc ()
873 abiHash strs = do
874 hsc_env <- getSession
875 let fc = hsc_FC hsc_env
876 let home_unit = hsc_home_unit hsc_env
877 let units = hsc_units hsc_env
878 let dflags = hsc_dflags hsc_env
879 let fopts = initFinderOpts dflags
880
881 liftIO $ do
882
883 let find_it str = do
884 let modname = mkModuleName str
885 r <- findImportedModule fc fopts units home_unit modname NoPkgQual
886 case r of
887 Found _ m -> return m
888 _error -> throwGhcException $ CmdLineError $ showSDoc dflags $
889 cannotFindModule hsc_env modname r
890
891 mods <- mapM find_it strs
892
893 let get_iface modl = loadUserInterface NotBoot (text "abiHash") modl
894 ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods
895
896 bh <- openBinMem (3*1024) -- just less than a block
897 put_ bh hiVersion
898 -- package hashes change when the compiler version changes (for now)
899 -- see #5328
900 mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces
901 f <- fingerprintBinMem bh
902
903 putStrLn (showPpr dflags f)
904
905 -- -----------------------------------------------------------------------------
906 -- Util
907
908 unknownFlagsErr :: [String] -> a
909 unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
910 where
911 oneError f =
912 "unrecognised flag: " ++ f ++ "\n" ++
913 (case match f (nubSort allNonDeprecatedFlags) of
914 [] -> ""
915 suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
916 -- fixes #11789
917 -- If the flag contains '=',
918 -- this uses both the whole and the left side of '=' for comparing.
919 match f allFlags
920 | elem '=' f =
921 let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags
922 fName = takeWhile (/= '=') f
923 in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)
924 | otherwise = fuzzyMatch f allFlags