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