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