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