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