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