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