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