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