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