1 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
3 -----------------------------------------------------------------------------
7 -- (c) The University of Glasgow 2005
9 -----------------------------------------------------------------------------
11 module Main (main) where
13 -- The official GHC API
15 import GHC ( -- DynFlags(..), HscTarget(..),
16 -- GhcMode(..), GhcLink(..),
21 -- Implementations of the various modes (--show-iface, mkdependHS. etc.)
22 import LoadIface ( showIface )
23 import HscMain ( newHscEnv )
24 import DriverPipeline ( oneShot, compileFile )
25 import DriverMkDepend ( doMkDependHS )
27 import InteractiveUI ( interactiveUI, ghciWelcomeMsg )
31 -- Various other random stuff that we need
34 import Packages ( dumpPackages )
35 import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
36 startPhase, isHaskellSrcFilename )
37 import BasicTypes ( failed )
39 import StaticFlagParser
47 import MonadUtils ( liftIO )
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 )
56 -- Standard Haskell libraries
58 import System.Environment
60 import System.FilePath
66 -----------------------------------------------------------------------------
69 -- time commands when run with -v
71 -- Win32 support: proper signal handling
72 -- reading the package configuration file is too slow
75 -----------------------------------------------------------------------------
76 -- GHC's command-line interface
80 hSetBuffering stdout NoBuffering
81 let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings")
82 GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do
83 -- 1. extract the -B flag from the args
86 let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
87 mbMinusB | null minusB_args = Nothing
88 | otherwise = Just (drop 2 (last minusB_args))
90 let argv1' = map (mkGeneralLocated "on the commandline") argv1
91 (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
93 -- 2. Parse the "mode" flags (--make, --interactive etc.)
94 (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
96 let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
98 -- If all we want to do is something like showing the version number
99 -- then do it now, before we start a GHC session etc. This makes
100 -- getting basic information much more resilient.
102 -- In particular, if we wait until later before giving the version
103 -- number then bootstrapping gets confused, as it tries to find out
104 -- what version of GHC it's using before package.conf exists, so
105 -- starting the session fails.
107 Left preStartupMode ->
108 do case preStartupMode of
109 ShowSupportedExtensions -> showSupportedExtensions
110 ShowVersion -> showVersion
111 ShowNumVersion -> putStrLn cProjectVersion
112 Print str -> putStrLn str
113 Right postStartupMode ->
114 -- start our GHC session
115 GHC.runGhc mbMinusB $ do
117 dflags <- GHC.getSessionDynFlags
119 case postStartupMode of
123 ShowInfo -> showInfo dflags
124 ShowGhcUsage -> showGhcUsage dflags
125 ShowGhciUsage -> showGhciUsage dflags
126 PrintWithDynFlags f -> putStrLn (f dflags)
127 Right postLoadMode ->
128 main' postLoadMode dflags argv3 flagWarnings
130 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
132 main' postLoadMode dflags0 args flagWarnings = do
133 -- set the default GhcMode, HscTarget and GhcLink. The HscTarget
134 -- can be further adjusted on a module by module basis, using only
135 -- the -fvia-C and -fasm flags. If the default HscTarget is not
136 -- HscC or HscAsm, -fvia-C and -fasm have no effect.
137 let dflt_target = hscTarget dflags0
139 = case postLoadMode of
140 DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)
141 DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)
142 DoMake -> (CompManager, dflt_target, LinkBinary)
143 DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)
144 DoAbiHash -> (OneShot, dflt_target, LinkBinary)
145 _ -> (OneShot, dflt_target, LinkBinary)
147 let dflags1 = dflags0{ ghcMode = mode,
150 -- leave out hscOutName for now
151 hscOutName = panic "Main.main:hscOutName not set",
152 verbosity = case postLoadMode of
157 -- turn on -fimplicit-import-qualified for GHCi now, so that it
158 -- can be overriden from the command-line
159 dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled
160 | DoEval _ <- postLoadMode = imp_qual_enabled
161 | otherwise = dflags1
162 where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified
164 -- The rest of the arguments are "dynamic"
165 -- Leftover ones are presumably files
166 (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
168 let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
170 handleSourceError (\e -> do
172 liftIO $ exitWith (ExitFailure 1)) $ do
173 liftIO $ handleFlagWarnings dflags2 flagWarnings'
175 -- make sure we clean up after ourselves
176 GHC.defaultCleanupHandler dflags2 $ do
178 liftIO $ showBanner postLoadMode dflags2
180 -- we've finished manipulating the DynFlags, update the session
181 _ <- GHC.setSessionDynFlags dflags2
182 dflags3 <- GHC.getSessionDynFlags
183 hsc_env <- GHC.getSession
186 -- To simplify the handling of filepaths, we normalise all filepaths right
187 -- away - e.g., for win32 platforms, backslashes are converted
188 -- into forward slashes.
189 normal_fileish_paths = map (normalise . unLoc) fileish_args
190 (srcs, objs) = partition_args normal_fileish_paths [] []
192 -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
194 liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)
196 ---------------- Display configuration -----------
197 when (verbosity dflags3 >= 4) $
198 liftIO $ dumpPackages dflags3
200 when (verbosity dflags3 >= 3) $ do
201 liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
203 ---------------- Final sanity checking -----------
204 liftIO $ checkOptions postLoadMode dflags3 srcs objs
206 ---------------- Do the business -----------
207 handleSourceError (\e -> do
209 liftIO $ exitWith (ExitFailure 1)) $ do
211 ShowInterface f -> liftIO $ doShowIface dflags3 f
212 DoMake -> doMake srcs
213 DoMkDependHS -> doMkDependHS (map fst srcs)
214 StopBefore p -> liftIO (oneShot hsc_env p srcs)
215 DoInteractive -> interactiveUI srcs Nothing
216 DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs
217 DoAbiHash -> abiHash srcs
219 liftIO $ dumpFinalStats dflags3
222 interactiveUI :: b -> c -> Ghc ()
224 ghcError (CmdLineError "not built for interactive use")
227 -- -----------------------------------------------------------------------------
228 -- Splitting arguments into source files and object files. This is where we
229 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
230 -- file indicating the phase specified by the -x option in force, if any.
232 partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
233 -> ([(String, Maybe Phase)], [String])
234 partition_args [] srcs objs = (reverse srcs, reverse objs)
235 partition_args ("-x":suff:args) srcs objs
236 | "none" <- suff = partition_args args srcs objs
237 | StopLn <- phase = partition_args args srcs (slurp ++ objs)
238 | otherwise = partition_args rest (these_srcs ++ srcs) objs
239 where phase = startPhase suff
240 (slurp,rest) = break (== "-x") args
241 these_srcs = zip slurp (repeat (Just phase))
242 partition_args (arg:args) srcs objs
243 | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
244 | otherwise = partition_args args srcs (arg:objs)
247 We split out the object files (.o, .dll) and add them
248 to v_Ld_inputs for use by the linker.
250 The following things should be considered compilation manager inputs:
252 - haskell source files (strings ending in .hs, .lhs or other
253 haskellish extension),
255 - module names (not forgetting hierarchical module names),
257 - and finally we consider everything not containing a '.' to be
258 a comp manager input, as shorthand for a .hs or .lhs filename.
260 Everything else is considered to be a linker object, and passed
261 straight through to the linker.
263 looks_like_an_input :: String -> Bool
264 looks_like_an_input m = isSourceFilename m
265 || looksLikeModuleName m
268 -- -----------------------------------------------------------------------------
269 -- Option sanity checks
271 -- | Ensure sanity of options.
273 -- Throws 'UsageError' or 'CmdLineError' if not.
274 checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
275 -- Final sanity checking before kicking off a compilation (pipeline).
276 checkOptions mode dflags srcs objs = do
277 -- Complain about any unknown flags
278 let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
279 when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
281 when (notNull (filter isRTSWay (wayNames dflags))
282 && isInterpretiveMode mode) $
283 hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
285 -- -prof and --interactive are not a good combination
286 when (notNull (filter (not . isRTSWay) (wayNames dflags))
287 && isInterpretiveMode mode) $
288 do ghcError (UsageError
289 "--interactive can't be used with -prof or -unreg.")
291 if (isJust (outputHi dflags) &&
292 (isCompManagerMode mode || srcs `lengthExceeds` 1))
293 then ghcError (UsageError "-ohi can only be used when compiling a single source file")
296 -- -o sanity checking
297 if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
298 && not (isLinkMode mode))
299 then ghcError (UsageError "can't apply -o to multiple source files")
302 let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
304 when (not_linking && not (null objs)) $
305 hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
307 -- Check that there are some input files
308 -- (except in the interactive case)
309 if null srcs && (null objs || not_linking) && needsInputsMode mode
310 then ghcError (UsageError "no input files")
313 -- Verify that output files point somewhere sensible.
314 verifyOutputFiles dflags
317 -- Compiler output options
319 -- called to verify that the output files & directories
320 -- point somewhere valid.
322 -- The assumption is that the directory portion of these output
323 -- options will have to exist by the time 'verifyOutputFiles'
326 verifyOutputFiles :: DynFlags -> IO ()
327 verifyOutputFiles dflags = do
328 -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
329 let ofile = outputFile dflags
330 when (isJust ofile) $ do
331 let fn = fromJust ofile
332 flg <- doesDirNameExist fn
333 when (not flg) (nonExistentDir "-o" fn)
334 let ohi = outputHi dflags
335 when (isJust ohi) $ do
336 let hi = fromJust ohi
337 flg <- doesDirNameExist hi
338 when (not flg) (nonExistentDir "-ohi" hi)
340 nonExistentDir flg dir =
341 ghcError (CmdLineError ("error: directory portion of " ++
342 show dir ++ " does not exist (used with " ++
343 show flg ++ " option.)"))
345 -----------------------------------------------------------------------------
346 -- GHC modes of operation
348 type Mode = Either PreStartupMode PostStartupMode
349 type PostStartupMode = Either PreLoadMode PostLoadMode
352 = ShowVersion -- ghc -V/--version
353 | ShowNumVersion -- ghc --numeric-version
354 | ShowSupportedExtensions -- ghc --supported-extensions
355 | Print String -- ghc --print-foo
357 showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
358 showVersionMode = mkPreStartupMode ShowVersion
359 showNumVersionMode = mkPreStartupMode ShowNumVersion
360 showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
362 mkPreStartupMode :: PreStartupMode -> Mode
363 mkPreStartupMode = Left
365 isShowVersionMode :: Mode -> Bool
366 isShowVersionMode (Left ShowVersion) = True
367 isShowVersionMode _ = False
369 isShowNumVersionMode :: Mode -> Bool
370 isShowNumVersionMode (Left ShowNumVersion) = True
371 isShowNumVersionMode _ = False
374 = ShowGhcUsage -- ghc -?
375 | ShowGhciUsage -- ghci -?
376 | ShowInfo -- ghc --info
377 | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
379 showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
380 showGhcUsageMode = mkPreLoadMode ShowGhcUsage
381 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
382 showInfoMode = mkPreLoadMode ShowInfo
384 printSetting :: String -> Mode
385 printSetting k = mkPreLoadMode (PrintWithDynFlags f)
386 where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
387 $ lookup k (compilerInfo dflags)
389 mkPreLoadMode :: PreLoadMode -> Mode
390 mkPreLoadMode = Right . Left
392 isShowGhcUsageMode :: Mode -> Bool
393 isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
394 isShowGhcUsageMode _ = False
396 isShowGhciUsageMode :: Mode -> Bool
397 isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
398 isShowGhciUsageMode _ = False
401 = ShowInterface FilePath -- ghc --show-iface
402 | DoMkDependHS -- ghc -M
403 | StopBefore Phase -- ghc -E | -C | -S
404 -- StopBefore StopLn is the default
405 | DoMake -- ghc --make
406 | DoInteractive -- ghc --interactive
407 | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
408 | DoAbiHash -- ghc --abi-hash
410 doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
411 doMkDependHSMode = mkPostLoadMode DoMkDependHS
412 doMakeMode = mkPostLoadMode DoMake
413 doInteractiveMode = mkPostLoadMode DoInteractive
414 doAbiHashMode = mkPostLoadMode DoAbiHash
416 showInterfaceMode :: FilePath -> Mode
417 showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
419 stopBeforeMode :: Phase -> Mode
420 stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
422 doEvalMode :: String -> Mode
423 doEvalMode str = mkPostLoadMode (DoEval [str])
425 mkPostLoadMode :: PostLoadMode -> Mode
426 mkPostLoadMode = Right . Right
428 isDoInteractiveMode :: Mode -> Bool
429 isDoInteractiveMode (Right (Right DoInteractive)) = True
430 isDoInteractiveMode _ = False
432 isStopLnMode :: Mode -> Bool
433 isStopLnMode (Right (Right (StopBefore StopLn))) = True
434 isStopLnMode _ = False
436 isDoMakeMode :: Mode -> Bool
437 isDoMakeMode (Right (Right DoMake)) = True
438 isDoMakeMode _ = False
441 isInteractiveMode :: PostLoadMode -> Bool
442 isInteractiveMode DoInteractive = True
443 isInteractiveMode _ = False
446 -- isInterpretiveMode: byte-code compiler involved
447 isInterpretiveMode :: PostLoadMode -> Bool
448 isInterpretiveMode DoInteractive = True
449 isInterpretiveMode (DoEval _) = True
450 isInterpretiveMode _ = False
452 needsInputsMode :: PostLoadMode -> Bool
453 needsInputsMode DoMkDependHS = True
454 needsInputsMode (StopBefore _) = True
455 needsInputsMode DoMake = True
456 needsInputsMode _ = False
458 -- True if we are going to attempt to link in this mode.
459 -- (we might not actually link, depending on the GhcLink flag)
460 isLinkMode :: PostLoadMode -> Bool
461 isLinkMode (StopBefore StopLn) = True
462 isLinkMode DoMake = True
463 isLinkMode DoInteractive = True
464 isLinkMode (DoEval _) = True
467 isCompManagerMode :: PostLoadMode -> Bool
468 isCompManagerMode DoMake = True
469 isCompManagerMode DoInteractive = True
470 isCompManagerMode (DoEval _) = True
471 isCompManagerMode _ = False
473 -- -----------------------------------------------------------------------------
474 -- Parsing the mode flag
476 parseModeFlags :: [Located String]
480 parseModeFlags args = do
481 let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
482 runCmdLine (processArgs mode_flags args)
484 mode = case mModeFlag of
485 Nothing -> doMakeMode
487 errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
488 when (not (null errs)) $ ghcError $ errorsToGhcException errs
489 return (mode, flags' ++ leftover, warns)
491 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
492 -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
493 -- so we collect the new ones and return them.
495 mode_flags :: [Flag ModeM]
497 [ ------- help / version ----------------------------------------------
498 Flag "?" (PassFlag (setMode showGhcUsageMode))
499 , Flag "-help" (PassFlag (setMode showGhcUsageMode))
500 , Flag "V" (PassFlag (setMode showVersionMode))
501 , Flag "-version" (PassFlag (setMode showVersionMode))
502 , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
503 , Flag "-info" (PassFlag (setMode showInfoMode))
504 , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
505 , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
507 [ Flag k' (PassFlag (setMode (printSetting k)))
508 | k <- ["Project version",
515 "Object splitting supported",
516 "Have native code generator",
519 "Tables next to code",
521 "Leading underscore",
528 let k' = "-print-" ++ map (replaceSpace . toLower) k
529 replaceSpace ' ' = '-'
532 ------- interfaces ----------------------------------------------------
533 [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
536 ------- primary modes ------------------------------------------------
537 , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
538 addFlag "-no-link" f))
539 , Flag "M" (PassFlag (setMode doMkDependHSMode))
540 , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
541 , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
542 addFlag "-fvia-C" f))
543 , Flag "S" (PassFlag (setMode (stopBeforeMode As)))
544 , Flag "-make" (PassFlag (setMode doMakeMode))
545 , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
546 , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))
547 , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
550 setMode :: Mode -> String -> EwM ModeM ()
551 setMode newMode newFlag = liftEwM $ do
552 (mModeFlag, errs, flags') <- getCmdLineState
553 let (modeFlag', errs') =
555 Nothing -> ((newMode, newFlag), errs)
556 Just (oldMode, oldFlag) ->
557 case (oldMode, newMode) of
558 -- -c/--make are allowed together, and mean --make -no-link
559 _ | isStopLnMode oldMode && isDoMakeMode newMode
560 || isStopLnMode newMode && isDoMakeMode oldMode ->
561 ((doMakeMode, "--make"), [])
563 -- If we have both --help and --interactive then we
564 -- want showGhciUsage
565 _ | isShowGhcUsageMode oldMode &&
566 isDoInteractiveMode newMode ->
567 ((showGhciUsageMode, oldFlag), [])
568 | isShowGhcUsageMode newMode &&
569 isDoInteractiveMode oldMode ->
570 ((showGhciUsageMode, newFlag), [])
571 -- Otherwise, --help/--version/--numeric-version always win
572 | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
573 | isDominantFlag newMode -> ((newMode, newFlag), [])
574 -- We need to accumulate eval flags like "-e foo -e bar"
575 (Right (Right (DoEval esOld)),
576 Right (Right (DoEval [eNew]))) ->
577 ((Right (Right (DoEval (eNew : esOld))), oldFlag),
579 -- Saying e.g. --interactive --interactive is OK
580 _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
581 -- Otherwise, complain
582 _ -> let err = flagMismatchErr oldFlag newFlag
583 in ((oldMode, oldFlag), err : errs)
584 putCmdLineState (Just modeFlag', errs', flags')
585 where isDominantFlag f = isShowGhcUsageMode f ||
586 isShowGhciUsageMode f ||
587 isShowVersionMode f ||
588 isShowNumVersionMode f
590 flagMismatchErr :: String -> String -> String
591 flagMismatchErr oldFlag newFlag
592 = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
594 addFlag :: String -> String -> EwM ModeM ()
595 addFlag s flag = liftEwM $ do
596 (m, e, flags') <- getCmdLineState
597 putCmdLineState (m, e, mkGeneralLocated loc s : flags')
598 where loc = "addFlag by " ++ flag ++ " on the commandline"
600 -- ----------------------------------------------------------------------------
603 doMake :: [(String,Maybe Phase)] -> Ghc ()
605 let (hs_srcs, non_hs_srcs) = partition haskellish srcs
607 haskellish (f,Nothing) =
608 looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
609 haskellish (_,Just phase) =
610 phase `notElem` [As, Cc, Cobjc, CmmCpp, Cmm, StopLn]
612 hsc_env <- GHC.getSession
614 -- if we have no haskell sources from which to do a dependency
615 -- analysis, then just do one-shot compilation and/or linking.
616 -- This means that "ghc Foo.o Bar.o -o baz" links the program as
619 then liftIO (oneShot hsc_env StopLn srcs)
622 o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
624 liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
626 targets <- mapM (uncurry GHC.guessTarget) hs_srcs
627 GHC.setTargets targets
628 ok_flag <- GHC.load LoadAllTargets
630 when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
634 -- ---------------------------------------------------------------------------
637 doShowIface :: DynFlags -> FilePath -> IO ()
638 doShowIface dflags file = do
639 hsc_env <- newHscEnv dflags
640 showIface hsc_env file
642 -- ---------------------------------------------------------------------------
643 -- Various banners and verbosity output.
645 showBanner :: PostLoadMode -> DynFlags -> IO ()
646 showBanner _postLoadMode dflags = do
647 let verb = verbosity dflags
650 -- Show the GHCi banner
651 when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
654 -- Display details of the configuration in verbose mode
656 do hPutStr stderr "Glasgow Haskell Compiler, Version "
657 hPutStr stderr cProjectVersion
658 hPutStr stderr ", stage "
659 hPutStr stderr cStage
660 hPutStr stderr " booted by GHC version "
661 hPutStrLn stderr cBooterVersion
663 -- We print out a Read-friendly string, but a prettier one than the
664 -- Show instance gives us
665 showInfo :: DynFlags -> IO ()
667 let sq x = " [" ++ x ++ "\n ]"
668 putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
670 showSupportedExtensions :: IO ()
671 showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
674 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
676 showGhcUsage :: DynFlags -> IO ()
677 showGhcUsage = showUsage False
679 showGhciUsage :: DynFlags -> IO ()
680 showGhciUsage = showUsage True
682 showUsage :: Bool -> DynFlags -> IO ()
683 showUsage ghci dflags = do
684 let usage_path = if ghci then ghciUsagePath dflags
685 else ghcUsagePath dflags
686 usage <- readFile usage_path
690 dump ('$':'$':s) = putStr progName >> dump s
691 dump (c:s) = putChar c >> dump s
693 dumpFinalStats :: DynFlags -> IO ()
694 dumpFinalStats dflags =
695 when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
697 dumpFastStringStats :: DynFlags -> IO ()
698 dumpFastStringStats dflags = do
699 buckets <- getFastStringTable
700 let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
701 msg = text "FastString stats:" $$
702 nest 4 (vcat [text "size: " <+> int (length buckets),
703 text "entries: " <+> int entries,
704 text "longest chain: " <+> int longest,
705 text "z-encoded: " <+> (is_z `pcntOf` entries),
706 text "has z-encoding: " <+> (has_z `pcntOf` entries)
708 -- we usually get more "has z-encoding" than "z-encoded", because
709 -- when we z-encode a string it might hash to the exact same string,
710 -- which will is not counted as "z-encoded". Only strings whose
711 -- Z-encoding is different from the original string are counted in
712 -- the "z-encoded" total.
715 x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
717 countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)
718 countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
719 countFS entries longest is_z has_z (b:bs) =
722 longest' = max len longest
723 entries' = entries + len
724 is_zs = length (filter isZEncoded b)
725 has_zs = length (filter hasZEncoding b)
727 countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs
729 -- -----------------------------------------------------------------------------
733 ghc --abi-hash Data.Foo System.Bar
735 Generates a combined hash of the ABI for modules Data.Foo and
736 System.Bar. The modules must already be compiled, and appropriate -i
737 options may be necessary in order to find the .hi files.
739 This is used by Cabal for generating the InstalledPackageId for a
740 package. The InstalledPackageId must change when the visible ABI of
741 the package chagnes, so during registration Cabal calls ghc --abi-hash
742 to get a hash of the package's ABI.
745 abiHash :: [(String, Maybe Phase)] -> Ghc ()
747 hsc_env <- getSession
748 let dflags = hsc_dflags hsc_env
753 let modname = mkModuleName str
754 r <- findImportedModule hsc_env modname Nothing
756 Found _ m -> return m
757 _error -> ghcError $ CmdLineError $ showSDoc $
758 cannotFindInterface dflags modname r
760 mods <- mapM find_it (map fst strs)
762 let get_iface modl = loadUserInterface False (text "abiHash") modl
763 ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods
765 bh <- openBinMem (3*1024) -- just less than a block
766 mapM_ (put_ bh . mi_mod_hash) ifaces
767 f <- fingerprintBinMem bh
769 putStrLn (showSDoc (ppr f))
771 -- -----------------------------------------------------------------------------
774 unknownFlagsErr :: [String] -> a
775 unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))