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