Merge branch 'master' of http://darcs.haskell.org/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 StaticFlagParser
41 import DynFlags
42 import ErrUtils
43 import FastString
44 import Outputable
45 import SrcLoc
46 import Util
47 import Panic
48 import MonadUtils ( liftIO )
49
50 -- Imports for --abi-hash
51 import LoadIface ( loadUserInterface )
52 import Module ( mkModuleName )
53 import Finder ( findImportedModule, cannotFindInterface )
54 import TcRnMonad ( initIfaceCheck )
55 import Binary ( openBinMem, put_, fingerprintBinMem )
56
57 -- Standard Haskell libraries
58 import System.IO
59 import System.Environment
60 import System.Exit
61 import System.FilePath
62 import Control.Monad
63 import Data.Char
64 import Data.List
65 import Data.Maybe
66
67 -----------------------------------------------------------------------------
68 -- ToDo:
69
70 -- time commands when run with -v
71 -- user ways
72 -- Win32 support: proper signal handling
73 -- reading the package configuration file is too slow
74 -- -K<size>
75
76 -----------------------------------------------------------------------------
77 -- GHC's command-line interface
78
79 main :: IO ()
80 main = do
81 hSetBuffering stdout NoBuffering
82 hSetBuffering stderr NoBuffering
83 GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
84 -- 1. extract the -B flag from the args
85 argv0 <- getArgs
86
87 let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
88 mbMinusB | null minusB_args = Nothing
89 | otherwise = Just (drop 2 (last minusB_args))
90
91 let argv1' = map (mkGeneralLocated "on the commandline") argv1
92 (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
93
94 -- 2. Parse the "mode" flags (--make, --interactive etc.)
95 (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
96
97 let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
98
99 -- If all we want to do is something like showing the version number
100 -- then do it now, before we start a GHC session etc. This makes
101 -- getting basic information much more resilient.
102
103 -- In particular, if we wait until later before giving the version
104 -- number then bootstrapping gets confused, as it tries to find out
105 -- what version of GHC it's using before package.conf exists, so
106 -- starting the session fails.
107 case mode of
108 Left preStartupMode ->
109 do case preStartupMode of
110 ShowSupportedExtensions -> showSupportedExtensions
111 ShowVersion -> showVersion
112 ShowNumVersion -> putStrLn cProjectVersion
113 Print str -> putStrLn str
114 Right postStartupMode ->
115 -- start our GHC session
116 GHC.runGhc mbMinusB $ do
117
118 dflags <- GHC.getSessionDynFlags
119
120 case postStartupMode of
121 Left preLoadMode ->
122 liftIO $ do
123 case preLoadMode of
124 ShowInfo -> showInfo dflags
125 ShowGhcUsage -> showGhcUsage dflags
126 ShowGhciUsage -> showGhciUsage dflags
127 PrintWithDynFlags f -> putStrLn (f dflags)
128 Right postLoadMode ->
129 main' postLoadMode dflags argv3 flagWarnings
130
131 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
132 -> Ghc ()
133 main' postLoadMode dflags0 args flagWarnings = do
134 -- set the default GhcMode, HscTarget and GhcLink. The HscTarget
135 -- can be further adjusted on a module by module basis, using only
136 -- the -fvia-C and -fasm flags. If the default HscTarget is not
137 -- HscC or HscAsm, -fvia-C and -fasm have no effect.
138 let dflt_target = hscTarget dflags0
139 (mode, lang, link)
140 = case postLoadMode of
141 DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)
142 DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)
143 DoMake -> (CompManager, dflt_target, LinkBinary)
144 DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)
145 DoAbiHash -> (OneShot, dflt_target, LinkBinary)
146 _ -> (OneShot, dflt_target, LinkBinary)
147
148 let dflags1 = dflags0{ ghcMode = mode,
149 hscTarget = lang,
150 ghcLink = link,
151 -- leave out hscOutName for now
152 hscOutName = panic "Main.main:hscOutName not set",
153 verbosity = case postLoadMode of
154 DoEval _ -> 0
155 _other -> 1
156 }
157
158 -- turn on -fimplicit-import-qualified for GHCi now, so that it
159 -- can be overriden from the command-line
160 -- XXX: this should really be in the interactive DynFlags, but
161 -- we don't set that until later in interactiveUI
162 dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled
163 | DoEval _ <- postLoadMode = imp_qual_enabled
164 | otherwise = dflags1
165 where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified
166
167 -- The rest of the arguments are "dynamic"
168 -- Leftover ones are presumably files
169 (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
170
171 GHC.prettyPrintGhcErrors dflags2 $ do
172
173 let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
174
175 handleSourceError (\e -> do
176 GHC.printException e
177 liftIO $ exitWith (ExitFailure 1)) $ do
178 liftIO $ handleFlagWarnings dflags2 flagWarnings'
179
180 -- make sure we clean up after ourselves
181 GHC.defaultCleanupHandler dflags2 $ do
182
183 liftIO $ showBanner postLoadMode dflags2
184
185 let
186 -- To simplify the handling of filepaths, we normalise all filepaths right
187 -- away - e.g., for win32 platforms, backslashes are converted
188 -- into forward slashes.
189 normal_fileish_paths = map (normalise . unLoc) fileish_args
190 (srcs, objs) = partition_args normal_fileish_paths [] []
191
192 dflags2a = dflags2 { ldInputs = objs ++ ldInputs dflags2 }
193
194 -- we've finished manipulating the DynFlags, update the session
195 _ <- GHC.setSessionDynFlags dflags2a
196 dflags3 <- GHC.getSessionDynFlags
197 hsc_env <- GHC.getSession
198
199 ---------------- Display configuration -----------
200 when (verbosity dflags3 >= 4) $
201 liftIO $ dumpPackages dflags3
202
203 when (verbosity dflags3 >= 3) $ do
204 liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
205
206 ---------------- Final sanity checking -----------
207 liftIO $ checkOptions postLoadMode dflags3 srcs objs
208
209 ---------------- Do the business -----------
210 handleSourceError (\e -> do
211 GHC.printException e
212 liftIO $ exitWith (ExitFailure 1)) $ do
213 case postLoadMode of
214 ShowInterface f -> liftIO $ doShowIface dflags3 f
215 DoMake -> doMake srcs
216 DoMkDependHS -> doMkDependHS (map fst srcs)
217 StopBefore p -> liftIO (oneShot hsc_env p srcs)
218 DoInteractive -> ghciUI srcs Nothing
219 DoEval exprs -> ghciUI srcs $ Just $ reverse exprs
220 DoAbiHash -> abiHash srcs
221
222 liftIO $ dumpFinalStats dflags3
223
224 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
225 #ifndef GHCI
226 ghciUI _ _ = ghcError (CmdLineError "not built for interactive use")
227 #else
228 ghciUI = interactiveUI defaultGhciSettings
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 ldInputs 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 wayRTSOnly (ways 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 . wayRTSOnly) (ways 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 = do -- TODO: We used to warn and ignore when
560 -- unregisterised, but we no longer know whether
561 -- we are unregisterised at this point. Should
562 -- we check later on?
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 dflags <- GHC.getSessionDynFlags
641 let dflags' = dflags { ldInputs = o_files ++ ldInputs dflags }
642 _ <- GHC.setSessionDynFlags dflags'
643
644 targets <- mapM (uncurry GHC.guessTarget) hs_srcs
645 GHC.setTargets targets
646 ok_flag <- GHC.load LoadAllTargets
647
648 when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
649 return ()
650
651
652 -- ---------------------------------------------------------------------------
653 -- --show-iface mode
654
655 doShowIface :: DynFlags -> FilePath -> IO ()
656 doShowIface dflags file = do
657 hsc_env <- newHscEnv dflags
658 showIface hsc_env file
659
660 -- ---------------------------------------------------------------------------
661 -- Various banners and verbosity output.
662
663 showBanner :: PostLoadMode -> DynFlags -> IO ()
664 showBanner _postLoadMode dflags = do
665 let verb = verbosity dflags
666
667 #ifdef GHCI
668 -- Show the GHCi banner
669 when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
670 #endif
671
672 -- Display details of the configuration in verbose mode
673 when (verb >= 2) $
674 do hPutStr stderr "Glasgow Haskell Compiler, Version "
675 hPutStr stderr cProjectVersion
676 hPutStr stderr ", stage "
677 hPutStr stderr cStage
678 hPutStr stderr " booted by GHC version "
679 hPutStrLn stderr cBooterVersion
680
681 -- We print out a Read-friendly string, but a prettier one than the
682 -- Show instance gives us
683 showInfo :: DynFlags -> IO ()
684 showInfo dflags = do
685 let sq x = " [" ++ x ++ "\n ]"
686 putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
687
688 showSupportedExtensions :: IO ()
689 showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
690
691 showVersion :: IO ()
692 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
693
694 showGhcUsage :: DynFlags -> IO ()
695 showGhcUsage = showUsage False
696
697 showGhciUsage :: DynFlags -> IO ()
698 showGhciUsage = showUsage True
699
700 showUsage :: Bool -> DynFlags -> IO ()
701 showUsage ghci dflags = do
702 let usage_path = if ghci then ghciUsagePath dflags
703 else ghcUsagePath dflags
704 usage <- readFile usage_path
705 dump usage
706 where
707 dump "" = return ()
708 dump ('$':'$':s) = putStr progName >> dump s
709 dump (c:s) = putChar c >> dump s
710
711 dumpFinalStats :: DynFlags -> IO ()
712 dumpFinalStats dflags =
713 when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
714
715 dumpFastStringStats :: DynFlags -> IO ()
716 dumpFastStringStats dflags = do
717 buckets <- getFastStringTable
718 let (entries, longest, has_z) = countFS 0 0 0 buckets
719 msg = text "FastString stats:" $$
720 nest 4 (vcat [text "size: " <+> int (length buckets),
721 text "entries: " <+> int entries,
722 text "longest chain: " <+> int longest,
723 text "has z-encoding: " <+> (has_z `pcntOf` entries)
724 ])
725 -- we usually get more "has z-encoding" than "z-encoded", because
726 -- when we z-encode a string it might hash to the exact same string,
727 -- which will is not counted as "z-encoded". Only strings whose
728 -- Z-encoding is different from the original string are counted in
729 -- the "z-encoded" total.
730 putMsg dflags msg
731 where
732 x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
733
734 countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
735 countFS entries longest has_z [] = (entries, longest, has_z)
736 countFS entries longest has_z (b:bs) =
737 let
738 len = length b
739 longest' = max len longest
740 entries' = entries + len
741 has_zs = length (filter hasZEncoding b)
742 in
743 countFS entries' longest' (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 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 $ concatMap oneError fs
795 where
796 oneError f =
797 "unrecognised flag: " ++ f ++ "\n" ++
798 (case fuzzyMatch f (nub allFlags) of
799 [] -> ""
800 suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))