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