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