Remove DynFlags's hscOutName field
[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 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 = objs ++ ldInputs dflags4 }
202
203 -- we've finished manipulating the DynFlags, update the session
204 _ <- GHC.setSessionDynFlags dflags5
205 dflags6 <- GHC.getSessionDynFlags
206 hsc_env <- GHC.getSession
207
208 ---------------- Display configuration -----------
209 when (verbosity dflags6 >= 4) $
210 liftIO $ dumpPackages dflags6
211
212 when (verbosity dflags6 >= 3) $ do
213 liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
214
215 ---------------- Final sanity checking -----------
216 liftIO $ checkOptions postLoadMode dflags6 srcs objs
217
218 ---------------- Do the business -----------
219 handleSourceError (\e -> do
220 GHC.printException e
221 liftIO $ exitWith (ExitFailure 1)) $ do
222 case postLoadMode of
223 ShowInterface f -> liftIO $ doShowIface dflags6 f
224 DoMake -> doMake srcs
225 DoMkDependHS -> doMkDependHS (map fst srcs)
226 StopBefore p -> liftIO (oneShot hsc_env p srcs)
227 DoInteractive -> ghciUI srcs Nothing
228 DoEval exprs -> ghciUI srcs $ Just $ reverse exprs
229 DoAbiHash -> abiHash srcs
230
231 liftIO $ dumpFinalStats dflags6
232
233 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
234 #ifndef GHCI
235 ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use")
236 #else
237 ghciUI = interactiveUI defaultGhciSettings
238 #endif
239
240 -- -----------------------------------------------------------------------------
241 -- Splitting arguments into source files and object files. This is where we
242 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
243 -- file indicating the phase specified by the -x option in force, if any.
244
245 partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
246 -> ([(String, Maybe Phase)], [String])
247 partition_args [] srcs objs = (reverse srcs, reverse objs)
248 partition_args ("-x":suff:args) srcs objs
249 | "none" <- suff = partition_args args srcs objs
250 | StopLn <- phase = partition_args args srcs (slurp ++ objs)
251 | otherwise = partition_args rest (these_srcs ++ srcs) objs
252 where phase = startPhase suff
253 (slurp,rest) = break (== "-x") args
254 these_srcs = zip slurp (repeat (Just phase))
255 partition_args (arg:args) srcs objs
256 | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
257 | otherwise = partition_args args srcs (arg:objs)
258
259 {-
260 We split out the object files (.o, .dll) and add them
261 to ldInputs for use by the linker.
262
263 The following things should be considered compilation manager inputs:
264
265 - haskell source files (strings ending in .hs, .lhs or other
266 haskellish extension),
267
268 - module names (not forgetting hierarchical module names),
269
270 - things beginning with '-' are flags that were not recognised by
271 the flag parser, and we want them to generate errors later in
272 checkOptions, so we class them as source files (#5921)
273
274 - and finally we consider everything not containing a '.' to be
275 a comp manager input, as shorthand for a .hs or .lhs filename.
276
277 Everything else is considered to be a linker object, and passed
278 straight through to the linker.
279 -}
280 looks_like_an_input :: String -> Bool
281 looks_like_an_input m = isSourceFilename m
282 || looksLikeModuleName m
283 || "-" `isPrefixOf` m
284 || '.' `notElem` m
285
286 -- -----------------------------------------------------------------------------
287 -- Option sanity checks
288
289 -- | Ensure sanity of options.
290 --
291 -- Throws 'UsageError' or 'CmdLineError' if not.
292 checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
293 -- Final sanity checking before kicking off a compilation (pipeline).
294 checkOptions mode dflags srcs objs = do
295 -- Complain about any unknown flags
296 let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
297 when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
298
299 when (notNull (filter wayRTSOnly (ways dflags))
300 && isInterpretiveMode mode) $
301 hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
302
303 -- -prof and --interactive are not a good combination
304 when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
305 && isInterpretiveMode mode) $
306 do throwGhcException (UsageError
307 "--interactive can't be used with -prof or -unreg.")
308 -- -ohi sanity check
309 if (isJust (outputHi dflags) &&
310 (isCompManagerMode mode || srcs `lengthExceeds` 1))
311 then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
312 else do
313
314 -- -o sanity checking
315 if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
316 && not (isLinkMode mode))
317 then throwGhcException (UsageError "can't apply -o to multiple source files")
318 else do
319
320 let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
321
322 when (not_linking && not (null objs)) $
323 hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
324
325 -- Check that there are some input files
326 -- (except in the interactive case)
327 if null srcs && (null objs || not_linking) && needsInputsMode mode
328 then throwGhcException (UsageError "no input files")
329 else do
330
331 -- Verify that output files point somewhere sensible.
332 verifyOutputFiles dflags
333
334
335 -- Compiler output options
336
337 -- called to verify that the output files & directories
338 -- point somewhere valid.
339 --
340 -- The assumption is that the directory portion of these output
341 -- options will have to exist by the time 'verifyOutputFiles'
342 -- is invoked.
343 --
344 verifyOutputFiles :: DynFlags -> IO ()
345 verifyOutputFiles dflags = do
346 -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
347 let ofile = outputFile dflags
348 when (isJust ofile) $ do
349 let fn = fromJust ofile
350 flg <- doesDirNameExist fn
351 when (not flg) (nonExistentDir "-o" fn)
352 let ohi = outputHi dflags
353 when (isJust ohi) $ do
354 let hi = fromJust ohi
355 flg <- doesDirNameExist hi
356 when (not flg) (nonExistentDir "-ohi" hi)
357 where
358 nonExistentDir flg dir =
359 throwGhcException (CmdLineError ("error: directory portion of " ++
360 show dir ++ " does not exist (used with " ++
361 show flg ++ " option.)"))
362
363 -----------------------------------------------------------------------------
364 -- GHC modes of operation
365
366 type Mode = Either PreStartupMode PostStartupMode
367 type PostStartupMode = Either PreLoadMode PostLoadMode
368
369 data PreStartupMode
370 = ShowVersion -- ghc -V/--version
371 | ShowNumVersion -- ghc --numeric-version
372 | ShowSupportedExtensions -- ghc --supported-extensions
373
374 showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
375 showVersionMode = mkPreStartupMode ShowVersion
376 showNumVersionMode = mkPreStartupMode ShowNumVersion
377 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
378
379 mkPreStartupMode :: PreStartupMode -> Mode
380 mkPreStartupMode = Left
381
382 isShowVersionMode :: Mode -> Bool
383 isShowVersionMode (Left ShowVersion) = True
384 isShowVersionMode _ = False
385
386 isShowNumVersionMode :: Mode -> Bool
387 isShowNumVersionMode (Left ShowNumVersion) = True
388 isShowNumVersionMode _ = False
389
390 data PreLoadMode
391 = ShowGhcUsage -- ghc -?
392 | ShowGhciUsage -- ghci -?
393 | ShowInfo -- ghc --info
394 | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
395
396 showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
397 showGhcUsageMode = mkPreLoadMode ShowGhcUsage
398 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
399 showInfoMode = mkPreLoadMode ShowInfo
400
401 printSetting :: String -> Mode
402 printSetting k = mkPreLoadMode (PrintWithDynFlags f)
403 where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
404 $ lookup k (compilerInfo dflags)
405
406 mkPreLoadMode :: PreLoadMode -> Mode
407 mkPreLoadMode = Right . Left
408
409 isShowGhcUsageMode :: Mode -> Bool
410 isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
411 isShowGhcUsageMode _ = False
412
413 isShowGhciUsageMode :: Mode -> Bool
414 isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
415 isShowGhciUsageMode _ = False
416
417 data PostLoadMode
418 = ShowInterface FilePath -- ghc --show-iface
419 | DoMkDependHS -- ghc -M
420 | StopBefore Phase -- ghc -E | -C | -S
421 -- StopBefore StopLn is the default
422 | DoMake -- ghc --make
423 | DoInteractive -- ghc --interactive
424 | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
425 | DoAbiHash -- ghc --abi-hash
426
427 doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
428 doMkDependHSMode = mkPostLoadMode DoMkDependHS
429 doMakeMode = mkPostLoadMode DoMake
430 doInteractiveMode = mkPostLoadMode DoInteractive
431 doAbiHashMode = mkPostLoadMode DoAbiHash
432
433 showInterfaceMode :: FilePath -> Mode
434 showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
435
436 stopBeforeMode :: Phase -> Mode
437 stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
438
439 doEvalMode :: String -> Mode
440 doEvalMode str = mkPostLoadMode (DoEval [str])
441
442 mkPostLoadMode :: PostLoadMode -> Mode
443 mkPostLoadMode = Right . Right
444
445 isDoInteractiveMode :: Mode -> Bool
446 isDoInteractiveMode (Right (Right DoInteractive)) = True
447 isDoInteractiveMode _ = False
448
449 isStopLnMode :: Mode -> Bool
450 isStopLnMode (Right (Right (StopBefore StopLn))) = True
451 isStopLnMode _ = False
452
453 isDoMakeMode :: Mode -> Bool
454 isDoMakeMode (Right (Right DoMake)) = True
455 isDoMakeMode _ = False
456
457 #ifdef GHCI
458 isInteractiveMode :: PostLoadMode -> Bool
459 isInteractiveMode DoInteractive = True
460 isInteractiveMode _ = False
461 #endif
462
463 -- isInterpretiveMode: byte-code compiler involved
464 isInterpretiveMode :: PostLoadMode -> Bool
465 isInterpretiveMode DoInteractive = True
466 isInterpretiveMode (DoEval _) = True
467 isInterpretiveMode _ = False
468
469 needsInputsMode :: PostLoadMode -> Bool
470 needsInputsMode DoMkDependHS = True
471 needsInputsMode (StopBefore _) = True
472 needsInputsMode DoMake = True
473 needsInputsMode _ = False
474
475 -- True if we are going to attempt to link in this mode.
476 -- (we might not actually link, depending on the GhcLink flag)
477 isLinkMode :: PostLoadMode -> Bool
478 isLinkMode (StopBefore StopLn) = True
479 isLinkMode DoMake = True
480 isLinkMode DoInteractive = True
481 isLinkMode (DoEval _) = True
482 isLinkMode _ = False
483
484 isCompManagerMode :: PostLoadMode -> Bool
485 isCompManagerMode DoMake = True
486 isCompManagerMode DoInteractive = True
487 isCompManagerMode (DoEval _) = True
488 isCompManagerMode _ = False
489
490 -- -----------------------------------------------------------------------------
491 -- Parsing the mode flag
492
493 parseModeFlags :: [Located String]
494 -> IO (Mode,
495 [Located String],
496 [Located String])
497 parseModeFlags args = do
498 let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
499 runCmdLine (processArgs mode_flags args)
500 (Nothing, [], [])
501 mode = case mModeFlag of
502 Nothing -> doMakeMode
503 Just (m, _) -> m
504 errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
505 when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
506 return (mode, flags' ++ leftover, warns)
507
508 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
509 -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
510 -- so we collect the new ones and return them.
511
512 mode_flags :: [Flag ModeM]
513 mode_flags =
514 [ ------- help / version ----------------------------------------------
515 Flag "?" (PassFlag (setMode showGhcUsageMode))
516 , Flag "-help" (PassFlag (setMode showGhcUsageMode))
517 , Flag "V" (PassFlag (setMode showVersionMode))
518 , Flag "-version" (PassFlag (setMode showVersionMode))
519 , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
520 , Flag "-info" (PassFlag (setMode showInfoMode))
521 , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
522 , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
523 ] ++
524 [ Flag k' (PassFlag (setMode (printSetting k)))
525 | k <- ["Project version",
526 "Booter version",
527 "Stage",
528 "Build platform",
529 "Host platform",
530 "Target platform",
531 "Have interpreter",
532 "Object splitting supported",
533 "Have native code generator",
534 "Support SMP",
535 "Unregisterised",
536 "Tables next to code",
537 "RTS ways",
538 "Leading underscore",
539 "Debug on",
540 "LibDir",
541 "Global Package DB",
542 "C compiler flags",
543 "Gcc Linker flags",
544 "Ld Linker flags"],
545 let k' = "-print-" ++ map (replaceSpace . toLower) k
546 replaceSpace ' ' = '-'
547 replaceSpace c = c
548 ] ++
549 ------- interfaces ----------------------------------------------------
550 [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
551 "--show-iface"))
552
553 ------- primary modes ------------------------------------------------
554 , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
555 addFlag "-no-link" f))
556 , Flag "M" (PassFlag (setMode doMkDependHSMode))
557 , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
558 , Flag "C" (PassFlag (setMode (stopBeforeMode HCc)))
559 , Flag "S" (PassFlag (setMode (stopBeforeMode As)))
560 , Flag "-make" (PassFlag (setMode doMakeMode))
561 , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
562 , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))
563 , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
564 ]
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 (gopt 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 -> throwGhcException $ 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 = throwGhcException $ 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))