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