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