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(..),
17 LoadHowMuch(..), -- dopt, DynFlag(..),
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 )
30 -- Various other random stuff that we need
33 import Packages ( dumpPackages )
34 import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
35 startPhase, isHaskellSrcFilename )
36 import BasicTypes ( failed )
38 import StaticFlagParser
46 -- import MonadUtils ( liftIO )
48 -- Standard Haskell libraries
50 import System.Environment
52 import System.FilePath
58 -----------------------------------------------------------------------------
61 -- time commands when run with -v
63 -- Win32 support: proper signal handling
64 -- reading the package configuration file is too slow
67 -----------------------------------------------------------------------------
68 -- GHC's command-line interface
72 GHC.defaultErrorHandler defaultDynFlags $ do
73 -- 1. extract the -B flag from the args
76 let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
77 mbMinusB | null minusB_args = Nothing
78 | otherwise = Just (drop 2 (last minusB_args))
80 let argv1' = map (mkGeneralLocated "on the commandline") argv1
81 (argv2, staticFlagWarnings) <- parseStaticFlags argv1'
83 -- 2. Parse the "mode" flags (--make, --interactive etc.)
84 (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
86 let flagWarnings = staticFlagWarnings ++ modeFlagWarnings
88 -- If all we want to do is something like showing the version number
89 -- then do it now, before we start a GHC session etc. This makes
90 -- getting basic information much more resilient.
92 -- In particular, if we wait until later before giving the version
93 -- number then bootstrapping gets confused, as it tries to find out
94 -- what version of GHC it's using before package.conf exists, so
95 -- starting the session fails.
97 Left preStartupMode ->
98 do case preStartupMode of
99 ShowSupportedLanguages -> showSupportedLanguages
100 ShowVersion -> showVersion
101 ShowNumVersion -> putStrLn cProjectVersion
102 Print str -> putStrLn str
103 Right postStartupMode ->
104 -- start our GHC session
105 GHC.runGhc mbMinusB $ do
107 dflags <- GHC.getSessionDynFlags
109 case postStartupMode of
113 ShowInfo -> showInfo dflags
114 ShowGhcUsage -> showGhcUsage dflags
115 ShowGhciUsage -> showGhciUsage dflags
116 PrintWithDynFlags f -> putStrLn (f dflags)
117 Right postLoadMode ->
118 main' postLoadMode dflags argv3 flagWarnings
120 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
122 main' postLoadMode dflags0 args flagWarnings = do
123 -- set the default GhcMode, HscTarget and GhcLink. The HscTarget
124 -- can be further adjusted on a module by module basis, using only
125 -- the -fvia-C and -fasm flags. If the default HscTarget is not
126 -- HscC or HscAsm, -fvia-C and -fasm have no effect.
127 let dflt_target = hscTarget dflags0
129 = case postLoadMode of
130 DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)
131 DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)
132 DoMake -> (CompManager, dflt_target, LinkBinary)
133 DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)
134 _ -> (OneShot, dflt_target, LinkBinary)
136 let dflags1 = dflags0{ ghcMode = mode,
139 -- leave out hscOutName for now
140 hscOutName = panic "Main.main:hscOutName not set",
141 verbosity = case postLoadMode of
146 -- turn on -fimplicit-import-qualified for GHCi now, so that it
147 -- can be overriden from the command-line
148 dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled
149 | DoEval _ <- postLoadMode = imp_qual_enabled
150 | otherwise = dflags1
151 where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified
153 -- The rest of the arguments are "dynamic"
154 -- Leftover ones are presumably files
155 (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args
157 let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
159 handleSourceError (\e -> do
160 GHC.printExceptionAndWarnings e
161 liftIO $ exitWith (ExitFailure 1)) $
162 handleFlagWarnings dflags2 flagWarnings'
164 -- make sure we clean up after ourselves
165 GHC.defaultCleanupHandler dflags2 $ do
167 liftIO $ showBanner postLoadMode dflags2
169 -- we've finished manipulating the DynFlags, update the session
170 _ <- GHC.setSessionDynFlags dflags2
171 dflags3 <- GHC.getSessionDynFlags
172 hsc_env <- GHC.getSession
175 -- To simplify the handling of filepaths, we normalise all filepaths right
176 -- away - e.g., for win32 platforms, backslashes are converted
177 -- into forward slashes.
178 normal_fileish_paths = map (normalise . unLoc) fileish_args
179 (srcs, objs) = partition_args normal_fileish_paths [] []
181 -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
183 liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs)
185 ---------------- Display configuration -----------
186 when (verbosity dflags3 >= 4) $
187 liftIO $ dumpPackages dflags3
189 when (verbosity dflags3 >= 3) $ do
190 liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
192 ---------------- Final sanity checking -----------
193 liftIO $ checkOptions postLoadMode dflags3 srcs objs
195 ---------------- Do the business -----------
196 handleSourceError (\e -> do
197 GHC.printExceptionAndWarnings e
198 liftIO $ exitWith (ExitFailure 1)) $ do
200 ShowInterface f -> liftIO $ doShowIface dflags3 f
201 DoMake -> doMake srcs
202 DoMkDependHS -> doMkDependHS (map fst srcs)
203 StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings
204 DoInteractive -> interactiveUI srcs Nothing
205 DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs
207 liftIO $ dumpFinalStats dflags3
210 interactiveUI :: b -> c -> Ghc ()
212 ghcError (CmdLineError "not built for interactive use")
215 -- -----------------------------------------------------------------------------
216 -- Splitting arguments into source files and object files. This is where we
217 -- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
218 -- file indicating the phase specified by the -x option in force, if any.
220 partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
221 -> ([(String, Maybe Phase)], [String])
222 partition_args [] srcs objs = (reverse srcs, reverse objs)
223 partition_args ("-x":suff:args) srcs objs
224 | "none" <- suff = partition_args args srcs objs
225 | StopLn <- phase = partition_args args srcs (slurp ++ objs)
226 | otherwise = partition_args rest (these_srcs ++ srcs) objs
227 where phase = startPhase suff
228 (slurp,rest) = break (== "-x") args
229 these_srcs = zip slurp (repeat (Just phase))
230 partition_args (arg:args) srcs objs
231 | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
232 | otherwise = partition_args args srcs (arg:objs)
235 We split out the object files (.o, .dll) and add them
236 to v_Ld_inputs for use by the linker.
238 The following things should be considered compilation manager inputs:
240 - haskell source files (strings ending in .hs, .lhs or other
241 haskellish extension),
243 - module names (not forgetting hierarchical module names),
245 - and finally we consider everything not containing a '.' to be
246 a comp manager input, as shorthand for a .hs or .lhs filename.
248 Everything else is considered to be a linker object, and passed
249 straight through to the linker.
251 looks_like_an_input :: String -> Bool
252 looks_like_an_input m = isSourceFilename m
253 || looksLikeModuleName m
256 -- -----------------------------------------------------------------------------
257 -- Option sanity checks
259 -- | Ensure sanity of options.
261 -- Throws 'UsageError' or 'CmdLineError' if not.
262 checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
263 -- Final sanity checking before kicking off a compilation (pipeline).
264 checkOptions mode dflags srcs objs = do
265 -- Complain about any unknown flags
266 let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
267 when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
269 when (notNull (filter isRTSWay (wayNames dflags))
270 && isInterpretiveMode mode) $
271 hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
273 -- -prof and --interactive are not a good combination
274 when (notNull (filter (not . isRTSWay) (wayNames dflags))
275 && isInterpretiveMode mode) $
276 do ghcError (UsageError
277 "--interactive can't be used with -prof or -unreg.")
279 if (isJust (outputHi dflags) &&
280 (isCompManagerMode mode || srcs `lengthExceeds` 1))
281 then ghcError (UsageError "-ohi can only be used when compiling a single source file")
284 -- -o sanity checking
285 if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
286 && not (isLinkMode mode))
287 then ghcError (UsageError "can't apply -o to multiple source files")
290 let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
292 when (not_linking && not (null objs)) $
293 hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
295 -- Check that there are some input files
296 -- (except in the interactive case)
297 if null srcs && (null objs || not_linking) && needsInputsMode mode
298 then ghcError (UsageError "no input files")
301 -- Verify that output files point somewhere sensible.
302 verifyOutputFiles dflags
305 -- Compiler output options
307 -- called to verify that the output files & directories
308 -- point somewhere valid.
310 -- The assumption is that the directory portion of these output
311 -- options will have to exist by the time 'verifyOutputFiles'
314 verifyOutputFiles :: DynFlags -> IO ()
315 verifyOutputFiles dflags = do
316 -- not -odir: we create the directory for -odir if it doesn't exist (#2278).
317 let ofile = outputFile dflags
318 when (isJust ofile) $ do
319 let fn = fromJust ofile
320 flg <- doesDirNameExist fn
321 when (not flg) (nonExistentDir "-o" fn)
322 let ohi = outputHi dflags
323 when (isJust ohi) $ do
324 let hi = fromJust ohi
325 flg <- doesDirNameExist hi
326 when (not flg) (nonExistentDir "-ohi" hi)
328 nonExistentDir flg dir =
329 ghcError (CmdLineError ("error: directory portion of " ++
330 show dir ++ " does not exist (used with " ++
331 show flg ++ " option.)"))
333 -----------------------------------------------------------------------------
334 -- GHC modes of operation
336 type Mode = Either PreStartupMode PostStartupMode
337 type PostStartupMode = Either PreLoadMode PostLoadMode
340 = ShowVersion -- ghc -V/--version
341 | ShowNumVersion -- ghc --numeric-version
342 | ShowSupportedLanguages -- ghc --supported-languages
343 | Print String -- ghc --print-foo
345 showVersionMode, showNumVersionMode, showSupportedLanguagesMode :: Mode
346 showVersionMode = mkPreStartupMode ShowVersion
347 showNumVersionMode = mkPreStartupMode ShowNumVersion
348 showSupportedLanguagesMode = mkPreStartupMode ShowSupportedLanguages
350 printMode :: String -> Mode
351 printMode str = mkPreStartupMode (Print str)
353 mkPreStartupMode :: PreStartupMode -> Mode
354 mkPreStartupMode = Left
356 isShowVersionMode :: Mode -> Bool
357 isShowVersionMode (Left ShowVersion) = True
358 isShowVersionMode _ = False
360 isShowNumVersionMode :: Mode -> Bool
361 isShowNumVersionMode (Left ShowNumVersion) = True
362 isShowNumVersionMode _ = False
365 = ShowGhcUsage -- ghc -?
366 | ShowGhciUsage -- ghci -?
367 | ShowInfo -- ghc --info
368 | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
370 showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
371 showGhcUsageMode = mkPreLoadMode ShowGhcUsage
372 showGhciUsageMode = mkPreLoadMode ShowGhciUsage
373 showInfoMode = mkPreLoadMode ShowInfo
375 printWithDynFlagsMode :: (DynFlags -> String) -> Mode
376 printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f)
378 mkPreLoadMode :: PreLoadMode -> Mode
379 mkPreLoadMode = Right . Left
381 isShowGhcUsageMode :: Mode -> Bool
382 isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
383 isShowGhcUsageMode _ = False
385 isShowGhciUsageMode :: Mode -> Bool
386 isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
387 isShowGhciUsageMode _ = False
390 = ShowInterface FilePath -- ghc --show-iface
391 | DoMkDependHS -- ghc -M
392 | StopBefore Phase -- ghc -E | -C | -S
393 -- StopBefore StopLn is the default
394 | DoMake -- ghc --make
395 | DoInteractive -- ghc --interactive
396 | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
398 doMkDependHSMode, doMakeMode, doInteractiveMode :: Mode
399 doMkDependHSMode = mkPostLoadMode DoMkDependHS
400 doMakeMode = mkPostLoadMode DoMake
401 doInteractiveMode = mkPostLoadMode DoInteractive
403 showInterfaceMode :: FilePath -> Mode
404 showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
406 stopBeforeMode :: Phase -> Mode
407 stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
409 doEvalMode :: String -> Mode
410 doEvalMode str = mkPostLoadMode (DoEval [str])
412 mkPostLoadMode :: PostLoadMode -> Mode
413 mkPostLoadMode = Right . Right
415 isDoInteractiveMode :: Mode -> Bool
416 isDoInteractiveMode (Right (Right DoInteractive)) = True
417 isDoInteractiveMode _ = False
420 isInteractiveMode :: PostLoadMode -> Bool
421 isInteractiveMode DoInteractive = True
422 isInteractiveMode _ = False
425 -- isInterpretiveMode: byte-code compiler involved
426 isInterpretiveMode :: PostLoadMode -> Bool
427 isInterpretiveMode DoInteractive = True
428 isInterpretiveMode (DoEval _) = True
429 isInterpretiveMode _ = False
431 needsInputsMode :: PostLoadMode -> Bool
432 needsInputsMode DoMkDependHS = True
433 needsInputsMode (StopBefore _) = True
434 needsInputsMode DoMake = True
435 needsInputsMode _ = False
437 -- True if we are going to attempt to link in this mode.
438 -- (we might not actually link, depending on the GhcLink flag)
439 isLinkMode :: PostLoadMode -> Bool
440 isLinkMode (StopBefore StopLn) = True
441 isLinkMode DoMake = True
442 isLinkMode DoInteractive = True
443 isLinkMode (DoEval _) = True
446 isCompManagerMode :: PostLoadMode -> Bool
447 isCompManagerMode DoMake = True
448 isCompManagerMode DoInteractive = True
449 isCompManagerMode (DoEval _) = True
450 isCompManagerMode _ = False
453 -- -----------------------------------------------------------------------------
454 -- Parsing the mode flag
456 parseModeFlags :: [Located String]
460 parseModeFlags args = do
461 let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
462 runCmdLine (processArgs mode_flags args)
464 mode = case mModeFlag of
465 Nothing -> stopBeforeMode StopLn
467 errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
468 when (not (null errs)) $ ghcError $ errorsToGhcException errs
469 return (mode, flags' ++ leftover, warns)
471 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
472 -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
473 -- so we collect the new ones and return them.
475 mode_flags :: [Flag ModeM]
477 [ ------- help / version ----------------------------------------------
478 Flag "?" (PassFlag (setMode showGhcUsageMode))
480 , Flag "-help" (PassFlag (setMode showGhcUsageMode))
482 , Flag "V" (PassFlag (setMode showVersionMode))
484 , Flag "-version" (PassFlag (setMode showVersionMode))
486 , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
488 , Flag "-info" (PassFlag (setMode showInfoMode))
490 , Flag "-supported-languages" (PassFlag (setMode showSupportedLanguagesMode))
493 [ Flag k' (PassFlag (setMode mode))
495 | (k, v) <- compilerInfo,
496 let k' = "-print-" ++ map (replaceSpace . toLower) k
497 replaceSpace ' ' = '-'
500 String str -> printMode str
501 FromDynFlags f -> printWithDynFlagsMode f
503 ------- interfaces ----------------------------------------------------
504 [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
508 ------- primary modes ------------------------------------------------
509 , Flag "M" (PassFlag (setMode doMkDependHSMode))
511 , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
513 , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
514 addFlag "-fvia-C" f))
516 , Flag "S" (PassFlag (setMode (stopBeforeMode As)))
518 , Flag "-make" (PassFlag (setMode doMakeMode))
520 , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
522 , Flag "e" (HasArg (\s -> setMode (doEvalMode s) "-e"))
525 -- -fno-code says to stop after Hsc but don't generate any code.
526 , Flag "fno-code" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
527 addFlag "-fno-code" f
528 addFlag "-fforce-recomp" f))
532 setMode :: Mode -> String -> ModeM ()
533 setMode newMode newFlag = do
534 (mModeFlag, errs, flags') <- getCmdLineState
535 let (modeFlag', errs') =
537 Nothing -> ((newMode, newFlag), errs)
538 Just (oldMode, oldFlag) ->
539 case (oldMode, newMode) of
540 -- If we have both --help and --interactive then we
541 -- want showGhciUsage
542 _ | isShowGhcUsageMode oldMode &&
543 isDoInteractiveMode newMode ->
544 ((showGhciUsageMode, oldFlag), [])
545 | isShowGhcUsageMode newMode &&
546 isDoInteractiveMode oldMode ->
547 ((showGhciUsageMode, newFlag), [])
548 -- Otherwise, --help/--version/--numeric-version always win
549 | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
550 | isDominantFlag newMode -> ((newMode, newFlag), [])
551 -- We need to accumulate eval flags like "-e foo -e bar"
552 (Right (Right (DoEval esOld)),
553 Right (Right (DoEval [eNew]))) ->
554 ((Right (Right (DoEval (eNew : esOld))), oldFlag),
556 -- Saying e.g. --interactive --interactive is OK
557 _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
558 -- Otherwise, complain
559 _ -> let err = flagMismatchErr oldFlag newFlag
560 in ((oldMode, oldFlag), err : errs)
561 putCmdLineState (Just modeFlag', errs', flags')
562 where isDominantFlag f = isShowGhcUsageMode f ||
563 isShowGhciUsageMode f ||
564 isShowVersionMode f ||
565 isShowNumVersionMode f
567 flagMismatchErr :: String -> String -> String
568 flagMismatchErr oldFlag newFlag
569 = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
571 addFlag :: String -> String -> ModeM ()
573 (m, e, flags') <- getCmdLineState
574 putCmdLineState (m, e, mkGeneralLocated loc s : flags')
575 where loc = "addFlag by " ++ flag ++ " on the commandline"
577 -- ----------------------------------------------------------------------------
580 doMake :: [(String,Maybe Phase)] -> Ghc ()
581 doMake [] = ghcError (UsageError "no input files")
583 let (hs_srcs, non_hs_srcs) = partition haskellish srcs
585 haskellish (f,Nothing) =
586 looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
587 haskellish (_,Just phase) =
588 phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
590 hsc_env <- GHC.getSession
591 o_files <- mapM (\x -> do
592 f <- compileFile hsc_env StopLn x
596 liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
598 targets <- mapM (uncurry GHC.guessTarget) hs_srcs
599 GHC.setTargets targets
600 ok_flag <- GHC.load LoadAllTargets
602 when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
606 -- ---------------------------------------------------------------------------
609 doShowIface :: DynFlags -> FilePath -> IO ()
610 doShowIface dflags file = do
611 hsc_env <- newHscEnv defaultCallbacks dflags
612 showIface hsc_env file
614 -- ---------------------------------------------------------------------------
615 -- Various banners and verbosity output.
617 showBanner :: PostLoadMode -> DynFlags -> IO ()
618 showBanner _postLoadMode dflags = do
619 let verb = verbosity dflags
622 -- Show the GHCi banner
623 when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
626 -- Display details of the configuration in verbose mode
628 do hPutStr stderr "Glasgow Haskell Compiler, Version "
629 hPutStr stderr cProjectVersion
630 hPutStr stderr ", for Haskell 98, stage "
631 hPutStr stderr cStage
632 hPutStr stderr " booted by GHC version "
633 hPutStrLn stderr cBooterVersion
635 -- We print out a Read-friendly string, but a prettier one than the
636 -- Show instance gives us
637 showInfo :: DynFlags -> IO ()
639 let sq x = " [" ++ x ++ "\n ]"
640 putStrLn $ sq $ concat $ intersperse "\n ," $ map (show . flatten) compilerInfo
641 where flatten (k, String v) = (k, v)
642 flatten (k, FromDynFlags f) = (k, f dflags)
644 showSupportedLanguages :: IO ()
645 showSupportedLanguages = mapM_ putStrLn supportedLanguages
648 showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
650 showGhcUsage :: DynFlags -> IO ()
651 showGhcUsage = showUsage False
653 showGhciUsage :: DynFlags -> IO ()
654 showGhciUsage = showUsage True
656 showUsage :: Bool -> DynFlags -> IO ()
657 showUsage ghci dflags = do
658 let usage_path = if ghci then ghciUsagePath dflags
659 else ghcUsagePath dflags
660 usage <- readFile usage_path
664 dump ('$':'$':s) = putStr progName >> dump s
665 dump (c:s) = putChar c >> dump s
667 dumpFinalStats :: DynFlags -> IO ()
668 dumpFinalStats dflags =
669 when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
671 dumpFastStringStats :: DynFlags -> IO ()
672 dumpFastStringStats dflags = do
673 buckets <- getFastStringTable
674 let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
675 msg = text "FastString stats:" $$
676 nest 4 (vcat [text "size: " <+> int (length buckets),
677 text "entries: " <+> int entries,
678 text "longest chain: " <+> int longest,
679 text "z-encoded: " <+> (is_z `pcntOf` entries),
680 text "has z-encoding: " <+> (has_z `pcntOf` entries)
682 -- we usually get more "has z-encoding" than "z-encoded", because
683 -- when we z-encode a string it might hash to the exact same string,
684 -- which will is not counted as "z-encoded". Only strings whose
685 -- Z-encoding is different from the original string are counted in
686 -- the "z-encoded" total.
689 x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
691 countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)
692 countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
693 countFS entries longest is_z has_z (b:bs) =
696 longest' = max len longest
697 entries' = entries + len
698 is_zs = length (filter isZEncoded b)
699 has_zs = length (filter hasZEncoding b)
701 countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs
703 -- -----------------------------------------------------------------------------
706 unknownFlagsErr :: [String] -> a
707 unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))