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