Don't make -C imply -fvia-C
[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 (setMode (stopBeforeMode HCc)))
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 setMode :: Mode -> String -> EwM ModeM ()
557 setMode newMode newFlag = liftEwM $ do
558 (mModeFlag, errs, flags') <- getCmdLineState
559 let (modeFlag', errs') =
560 case mModeFlag of
561 Nothing -> ((newMode, newFlag), errs)
562 Just (oldMode, oldFlag) ->
563 case (oldMode, newMode) of
564 -- -c/--make are allowed together, and mean --make -no-link
565 _ | isStopLnMode oldMode && isDoMakeMode newMode
566 || isStopLnMode newMode && isDoMakeMode oldMode ->
567 ((doMakeMode, "--make"), [])
568
569 -- If we have both --help and --interactive then we
570 -- want showGhciUsage
571 _ | isShowGhcUsageMode oldMode &&
572 isDoInteractiveMode newMode ->
573 ((showGhciUsageMode, oldFlag), [])
574 | isShowGhcUsageMode newMode &&
575 isDoInteractiveMode oldMode ->
576 ((showGhciUsageMode, newFlag), [])
577 -- Otherwise, --help/--version/--numeric-version always win
578 | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
579 | isDominantFlag newMode -> ((newMode, newFlag), [])
580 -- We need to accumulate eval flags like "-e foo -e bar"
581 (Right (Right (DoEval esOld)),
582 Right (Right (DoEval [eNew]))) ->
583 ((Right (Right (DoEval (eNew : esOld))), oldFlag),
584 errs)
585 -- Saying e.g. --interactive --interactive is OK
586 _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
587 -- Otherwise, complain
588 _ -> let err = flagMismatchErr oldFlag newFlag
589 in ((oldMode, oldFlag), err : errs)
590 putCmdLineState (Just modeFlag', errs', flags')
591 where isDominantFlag f = isShowGhcUsageMode f ||
592 isShowGhciUsageMode f ||
593 isShowVersionMode f ||
594 isShowNumVersionMode f
595
596 flagMismatchErr :: String -> String -> String
597 flagMismatchErr oldFlag newFlag
598 = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
599
600 addFlag :: String -> String -> EwM ModeM ()
601 addFlag s flag = liftEwM $ do
602 (m, e, flags') <- getCmdLineState
603 putCmdLineState (m, e, mkGeneralLocated loc s : flags')
604 where loc = "addFlag by " ++ flag ++ " on the commandline"
605
606 -- ----------------------------------------------------------------------------
607 -- Run --make mode
608
609 doMake :: [(String,Maybe Phase)] -> Ghc ()
610 doMake srcs = do
611 let (hs_srcs, non_hs_srcs) = partition haskellish srcs
612
613 haskellish (f,Nothing) =
614 looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
615 haskellish (_,Just phase) =
616 phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
617
618 hsc_env <- GHC.getSession
619
620 -- if we have no haskell sources from which to do a dependency
621 -- analysis, then just do one-shot compilation and/or linking.
622 -- This means that "ghc Foo.o Bar.o -o baz" links the program as
623 -- we expect.
624 if (null hs_srcs)
625 then liftIO (oneShot hsc_env StopLn srcs)
626 else do
627
628 o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
629 non_hs_srcs
630 dflags <- GHC.getSessionDynFlags
631 let dflags' = dflags { ldInputs = o_files ++ ldInputs dflags }
632 _ <- GHC.setSessionDynFlags dflags'
633
634 targets <- mapM (uncurry GHC.guessTarget) hs_srcs
635 GHC.setTargets targets
636 ok_flag <- GHC.load LoadAllTargets
637
638 when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
639 return ()
640
641
642 -- ---------------------------------------------------------------------------
643 -- --show-iface mode
644
645 doShowIface :: DynFlags -> FilePath -> IO ()
646 doShowIface dflags file = do
647 hsc_env <- newHscEnv dflags
648 showIface hsc_env file
649
650 -- ---------------------------------------------------------------------------
651 -- Various banners and verbosity output.
652
653 showBanner :: PostLoadMode -> DynFlags -> IO ()
654 showBanner _postLoadMode dflags = do
655 let verb = verbosity dflags
656
657 #ifdef GHCI
658 -- Show the GHCi banner
659 when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
660 #endif
661
662 -- Display details of the configuration in verbose mode
663 when (verb >= 2) $
664 do hPutStr stderr "Glasgow Haskell Compiler, Version "
665 hPutStr stderr cProjectVersion
666 hPutStr stderr ", stage "
667 hPutStr stderr cStage
668 hPutStr stderr " booted by GHC version "
669 hPutStrLn stderr cBooterVersion
670
671 -- We print out a Read-friendly string, but a prettier one than the
672 -- Show instance gives us
673 showInfo :: DynFlags -> IO ()
674 showInfo dflags = do
675 let sq x = " [" ++ x ++ "\n ]"
676 putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
677
678 showSupportedExtensions :: IO ()
679 showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
680
681 showVersion :: IO ()
682 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
683
684 showGhcUsage :: DynFlags -> IO ()
685 showGhcUsage = showUsage False
686
687 showGhciUsage :: DynFlags -> IO ()
688 showGhciUsage = showUsage True
689
690 showUsage :: Bool -> DynFlags -> IO ()
691 showUsage ghci dflags = do
692 let usage_path = if ghci then ghciUsagePath dflags
693 else ghcUsagePath dflags
694 usage <- readFile usage_path
695 dump usage
696 where
697 dump "" = return ()
698 dump ('$':'$':s) = putStr progName >> dump s
699 dump (c:s) = putChar c >> dump s
700
701 dumpFinalStats :: DynFlags -> IO ()
702 dumpFinalStats dflags =
703 when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
704
705 dumpFastStringStats :: DynFlags -> IO ()
706 dumpFastStringStats dflags = do
707 buckets <- getFastStringTable
708 let (entries, longest, has_z) = countFS 0 0 0 buckets
709 msg = text "FastString stats:" $$
710 nest 4 (vcat [text "size: " <+> int (length buckets),
711 text "entries: " <+> int entries,
712 text "longest chain: " <+> int longest,
713 text "has z-encoding: " <+> (has_z `pcntOf` entries)
714 ])
715 -- we usually get more "has z-encoding" than "z-encoded", because
716 -- when we z-encode a string it might hash to the exact same string,
717 -- which will is not counted as "z-encoded". Only strings whose
718 -- Z-encoding is different from the original string are counted in
719 -- the "z-encoded" total.
720 putMsg dflags msg
721 where
722 x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
723
724 countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)
725 countFS entries longest has_z [] = (entries, longest, has_z)
726 countFS entries longest has_z (b:bs) =
727 let
728 len = length b
729 longest' = max len longest
730 entries' = entries + len
731 has_zs = length (filter hasZEncoding b)
732 in
733 countFS entries' longest' (has_z + has_zs) bs
734
735 -- -----------------------------------------------------------------------------
736 -- ABI hash support
737
738 {-
739 ghc --abi-hash Data.Foo System.Bar
740
741 Generates a combined hash of the ABI for modules Data.Foo and
742 System.Bar. The modules must already be compiled, and appropriate -i
743 options may be necessary in order to find the .hi files.
744
745 This is used by Cabal for generating the InstalledPackageId for a
746 package. The InstalledPackageId must change when the visible ABI of
747 the package chagnes, so during registration Cabal calls ghc --abi-hash
748 to get a hash of the package's ABI.
749 -}
750
751 abiHash :: [(String, Maybe Phase)] -> Ghc ()
752 abiHash strs = do
753 hsc_env <- getSession
754 let dflags = hsc_dflags hsc_env
755
756 liftIO $ do
757
758 let find_it str = do
759 let modname = mkModuleName str
760 r <- findImportedModule hsc_env modname Nothing
761 case r of
762 Found _ m -> return m
763 _error -> throwGhcException $ CmdLineError $ showSDoc dflags $
764 cannotFindInterface dflags modname r
765
766 mods <- mapM find_it (map fst strs)
767
768 let get_iface modl = loadUserInterface False (text "abiHash") modl
769 ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
770
771 bh <- openBinMem (3*1024) -- just less than a block
772 put_ bh hiVersion
773 -- package hashes change when the compiler version changes (for now)
774 -- see #5328
775 mapM_ (put_ bh . mi_mod_hash) ifaces
776 f <- fingerprintBinMem bh
777
778 putStrLn (showPpr dflags f)
779
780 -- -----------------------------------------------------------------------------
781 -- Util
782
783 unknownFlagsErr :: [String] -> a
784 unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
785 where
786 oneError f =
787 "unrecognised flag: " ++ f ++ "\n" ++
788 (case fuzzyMatch f (nub allFlags) of
789 [] -> ""
790 suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))