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