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