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