#include "HsVersions.h"
-#ifdef GHCI
-import InteractiveUI ( ghciWelcomeMsg, interactiveUI )
-#endif
-
+-- The official GHC API
+import qualified GHC
+import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..),
+ LoadHowMuch(..), dopt, DynFlag(..) )
+import CmdLineParser
+-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
import MkIface ( showIface )
-import CompManager ( cmInit, cmLoadModules, cmDepAnal )
-import Config
-import SysTools
-import Packages ( dumpPackages, initPackages, haskell98PackageId,
- PackageIdH(..) )
-import DriverPipeline ( runPipeline, staticLink, doMkDLL )
-
+import DriverPipeline ( oneShot, compileFile )
import DriverMkDepend ( doMkDependHS )
-import DriverPhases ( Phase(..), isStopLn, isSourceFilename, anyHsc )
+import SysTools ( getTopDir, getUsageMsgPaths )
+#ifdef GHCI
+import InteractiveUI ( ghciWelcomeMsg, interactiveUI )
+#endif
-import DynFlags
-import StaticFlags ( parseStaticFlags, staticFlags, v_Ld_inputs )
-import CmdLineParser
+-- Various other random stuff that we need
+import Config ( cProjectVersion, cBooterVersion, cProjectName )
+import Packages ( dumpPackages, initPackages )
+import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
+ startPhase, isHaskellSrcFilename )
+import StaticFlags ( staticFlags, v_Ld_inputs, parseStaticFlags )
+import DynFlags ( defaultDynFlags )
import BasicTypes ( failed )
+import ErrUtils ( Message, debugTraceMsg, putMsg )
+import FastString ( getFastStringTable, isZEncoded, hasZEncoding )
+import Outputable
import Util
import Panic
-- Standard Haskell libraries
-import EXCEPTION ( throwDyn, Exception(..),
- AsyncException(StackOverflow) )
-
+import EXCEPTION ( throwDyn )
import IO
-import Directory ( doesFileExist, doesDirectoryExist )
+import Directory ( doesDirectoryExist )
import System ( getArgs, exitWith, ExitCode(..) )
import Monad
import List
-- -K<size>
-----------------------------------------------------------------------------
--- Main loop
+-- GHC's command-line interface
main =
- ---------------------------------------
- -- exception handlers
-
- -- top-level exception handler: any unrecognised exception is a compiler bug.
- handle (\exception -> do
- hFlush stdout
- case exception of
- -- an IO exception probably isn't our fault, so don't panic
- IOException _ -> hPutStrLn stderr (show exception)
- AsyncException StackOverflow ->
- hPutStrLn stderr "stack overflow: use +RTS -K<size> to increase it"
- _other -> hPutStr stderr (show (Panic (show exception)))
- exitWith (ExitFailure 1)
- ) $ do
-
- -- all error messages are propagated as exceptions
- handleDyn (\dyn -> do
- hFlush stdout
- case dyn of
- PhaseFailed _ code -> exitWith code
- Interrupted -> exitWith (ExitFailure 1)
- _ -> do hPutStrLn stderr (show (dyn :: GhcException))
- exitWith (ExitFailure 1)
- ) $ do
-
- installSignalHandlers
-
- ----------------------------------------
- -- command-line parsing
- argv0 <- getArgs
-
- -- 1. we grab the -B option if there is one
- let (minusB_args, argv1) = partition (prefixMatch "-B") argv0
- dflags0 <- initSysTools minusB_args defaultDynFlags
-
- -- 2. Parse the "mode" flags (--make, --interactive etc.)
- (cli_mode, argv2) <- parseModeFlags argv1
-
- -- 3. Parse the static flags
- argv3 <- parseStaticFlags argv2
-
- -- 4. Parse the dynamic flags
- dflags1 <- initDynFlags dflags0
-
- -- set the default HscTarget. The HscTarget can be further
- -- adjusted on a module by module basis, using only the -fvia-C and
- -- -fasm flags. If the default HscTarget is not HscC or HscAsm,
- -- -fvia-C and -fasm have no effect.
- let lang = case cli_mode of
- DoInteractive -> HscInterpreted
- DoEval _ -> HscInterpreted
- _other -> hscTarget dflags1
+ GHC.defaultErrorHandler defaultDynFlags $ do
+
+ argv0 <- getArgs
+ argv1 <- parseStaticFlags =<< GHC.initFromArgs argv0
- let mode = case cli_mode of
+ -- 2. Parse the "mode" flags (--make, --interactive etc.)
+ (cli_mode, argv2) <- parseModeFlags argv1
+
+ let mode = case cli_mode of
DoInteractive -> Interactive
DoEval _ -> Interactive
DoMake -> BatchCompile
DoMkDependHS -> MkDepend
_ -> OneShot
- let dflags2 = dflags1{ ghcMode = mode,
- hscTarget = lang,
- -- leave out hscOutName for now
- hscOutName = panic "Main.main:hscOutName not set",
- verbosity = case cli_mode of
+ -- start our GHC session
+ session <- GHC.newSession mode
+
+ dflags0 <- GHC.getSessionDynFlags session
+
+ -- set the default HscTarget. The HscTarget can be further
+ -- adjusted on a module by module basis, using only the -fvia-C and
+ -- -fasm flags. If the default HscTarget is not HscC or HscAsm,
+ -- -fvia-C and -fasm have no effect.
+ let lang = case cli_mode of
+ DoInteractive -> HscInterpreted
+ DoEval _ -> HscInterpreted
+ _other -> hscTarget dflags0
+
+ let dflags1 = dflags0{ ghcMode = mode,
+ hscTarget = lang,
+ -- leave out hscOutName for now
+ hscOutName = panic "Main.main:hscOutName not set",
+ verbosity = case cli_mode of
DoEval _ -> 0
_other -> 1
}
-- The rest of the arguments are "dynamic"
-- Leftover ones are presumably files
- (dflags3, fileish_args) <- parseDynamicFlags dflags2 argv3
+ (dflags2, fileish_args) <- GHC.parseDynamicFlags dflags1 argv2
-- make sure we clean up after ourselves
- later (unless (dopt Opt_KeepTmpFiles dflags3) $
- cleanTempFiles dflags3) $ do
- -- exceptions will be blocked while we clean the temporary files,
- -- so there shouldn't be any difficulty if we receive further
- -- signals.
+ GHC.defaultCleanupHandler dflags2 $ do
-- Display banner
- showBanner cli_mode dflags3
+ showBanner cli_mode dflags2
-- Read the package config(s), and process the package-related
-- command-line flags
- dflags <- initPackages dflags3
+ dflags <- initPackages dflags2
- let
- {-
- We split out the object files (.o, .dll) and add them
- to v_Ld_inputs for use by the linker.
-
- The following things should be considered compilation manager inputs:
-
- - haskell source files (strings ending in .hs, .lhs or other
- haskellish extension),
-
- - module names (not forgetting hierarchical module names),
-
- - and finally we consider everything not containing a '.' to be
- a comp manager input, as shorthand for a .hs or .lhs filename.
-
- Everything else is considered to be a linker object, and passed
- straight through to the linker.
- -}
- looks_like_an_input m = isSourceFilename m
- || looksLikeModuleName m
- || '.' `notElem` m
+ -- we've finished manipulating the DynFlags, update the session
+ GHC.setSessionDynFlags session dflags
+ let
-- To simplify the handling of filepaths, we normalise all filepaths right
-- away - e.g., for win32 platforms, backslashes are converted
-- into forward slashes.
normal_fileish_paths = map normalisePath fileish_args
- (srcs, objs) = partition looks_like_an_input normal_fileish_paths
+ (srcs, objs) = partition_args normal_fileish_paths [] []
- -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
- -- the command-line.
- mapM_ (consIORef v_Ld_inputs) (reverse objs)
+ -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
+ -- the command-line.
+ mapM_ (consIORef v_Ld_inputs) (reverse objs)
---------------- Display configuration -----------
- when (verbosity dflags >= 4) $
+ when (verbosity dflags >= 4) $
dumpPackages dflags
- when (verbosity dflags >= 3) $ do
+ when (verbosity dflags >= 3) $ do
hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
---------------- Final sanity checking -----------
- checkOptions cli_mode dflags srcs objs
+ checkOptions cli_mode dflags srcs objs
---------------- Do the business -----------
- case cli_mode of
+ case cli_mode of
ShowUsage -> showGhcUsage cli_mode
PrintLibdir -> do d <- getTopDir; putStrLn d
ShowVersion -> showVersion
ShowNumVersion -> putStrLn cProjectVersion
ShowInterface f -> showIface f
- DoMake -> doMake dflags srcs
- DoMkDependHS -> doMkDependHS dflags srcs
+ DoMake -> doMake session srcs
+ DoMkDependHS -> doMkDependHS session (map fst srcs)
StopBefore p -> oneShot dflags p srcs
- DoInteractive -> interactiveUI dflags srcs Nothing
- DoEval expr -> interactiveUI dflags srcs (Just expr)
+ DoInteractive -> interactiveUI session srcs Nothing
+ DoEval expr -> interactiveUI session srcs (Just expr)
- exitWith ExitSuccess
+ dumpFinalStats dflags
+ exitWith ExitSuccess
#ifndef GHCI
interactiveUI _ _ _ =
throwDyn (CmdLineError "not built for interactive use")
#endif
+-- -----------------------------------------------------------------------------
+-- Splitting arguments into source files and object files. This is where we
+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
+-- file indicating the phase specified by the -x option in force, if any.
+
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+ | "none" <- suff = partition_args args srcs objs
+ | StopLn <- phase = partition_args args srcs (slurp ++ objs)
+ | otherwise = partition_args rest (these_srcs ++ srcs) objs
+ where phase = startPhase suff
+ (slurp,rest) = break (== "-x") args
+ these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+ | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+ | otherwise = partition_args args srcs (arg:objs)
+
+ {-
+ We split out the object files (.o, .dll) and add them
+ to v_Ld_inputs for use by the linker.
+
+ The following things should be considered compilation manager inputs:
+
+ - haskell source files (strings ending in .hs, .lhs or other
+ haskellish extension),
+
+ - module names (not forgetting hierarchical module names),
+
+ - and finally we consider everything not containing a '.' to be
+ a comp manager input, as shorthand for a .hs or .lhs filename.
+
+ Everything else is considered to be a linker object, and passed
+ straight through to the linker.
+ -}
+looks_like_an_input m = isSourceFilename m
+ || looksLikeModuleName m
+ || '.' `notElem` m
-- -----------------------------------------------------------------------------
-- Option sanity checks
-checkOptions :: CmdLineMode -> DynFlags -> [String] -> [String] -> IO ()
+checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
-- Final sanity checking before kicking off a compilation (pipeline).
checkOptions cli_mode dflags srcs objs = do
-- Complain about any unknown flags
- let unknown_opts = [ f | f@('-':_) <- srcs ]
+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
-- -prof and --interactive are not a good combination
-- Check that there are some input files
-- (except in the interactive case)
- if null srcs && null objs && not (isInterpretiveMode cli_mode)
+ if null srcs && null objs && needsInputsMode cli_mode
then throwDyn (UsageError "no input files")
else do
--
verifyOutputFiles :: DynFlags -> IO ()
verifyOutputFiles dflags = do
- let odir = outputDir dflags
+ let odir = objectDir dflags
when (isJust odir) $ do
let dir = fromJust odir
flg <- doesDirectoryExist dir
isInterpretiveMode (DoEval _) = True
isInterpretiveMode _ = False
+needsInputsMode DoMkDependHS = True
+needsInputsMode (StopBefore _) = True
+needsInputsMode DoMake = True
+needsInputsMode _ = False
+
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
isLinkMode (StopBefore StopLn) = True
putCmdLineState (m, f, s:flags)
--- -----------------------------------------------------------------------------
--- Compile files in one-shot mode.
-
-oneShot :: DynFlags -> Phase -> [String] -> IO ()
-oneShot dflags stop_phase srcs = do
- o_files <- compileFiles stop_phase dflags srcs
- doLink dflags stop_phase o_files
-
-compileFiles :: Phase
- -> DynFlags
- -> [String] -- Source files
- -> IO [String] -- Object files
-compileFiles stop_phase dflags srcs
- = mapM (compileFile stop_phase dflags) srcs
-
-compileFile :: Phase -> DynFlags -> FilePath -> IO FilePath
-compileFile stop_phase dflags src = do
- exists <- doesFileExist src
- when (not exists) $
- throwDyn (CmdLineError ("does not exist: " ++ src))
-
- let
- split = dopt Opt_SplitObjs dflags
- o_file = outputFile dflags
- ghc_link = ghcLink dflags -- Set by -c or -no-link
-
- -- When linking, the -o argument refers to the linker's output.
- -- otherwise, we use it as the name for the pipeline's output.
- maybe_o_file
- | StopLn <- stop_phase, not (isNoLink ghc_link) = Nothing
- -- -o foo applies to linker
- | otherwise = o_file
- -- -o foo applies to the file we are compiling now
-
- stop_phase' = case stop_phase of
- As | split -> SplitAs
- other -> stop_phase
-
- (_, out_file) <- runPipeline stop_phase' dflags
- True maybe_o_file src Nothing{-no ModLocation-}
- return out_file
-
-
-doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
-doLink dflags stop_phase o_files
- | not (isStopLn stop_phase)
- = return () -- We stopped before the linking phase
-
- | otherwise
- = case ghcLink dflags of
- NoLink -> return ()
- StaticLink -> staticLink dflags o_files link_pkgs
- MkDLL -> doMkDLL dflags o_files link_pkgs
- where
- -- Always link in the haskell98 package for static linking. Other
- -- packages have to be specified via the -package flag.
- link_pkgs
- | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id]
- | otherwise = []
-
-
-- ----------------------------------------------------------------------------
-- Run --make mode
-doMake :: DynFlags -> [String] -> IO ()
-doMake dflags [] = throwDyn (UsageError "no input files")
-doMake dflags srcs = do
- state <- cmInit dflags
- graph <- cmDepAnal state srcs
- (_, ok_flag, _) <- cmLoadModules state graph
+doMake :: Session -> [(String,Maybe Phase)] -> IO ()
+doMake sess [] = throwDyn (UsageError "no input files")
+doMake sess srcs = do
+ let (hs_srcs, non_hs_srcs) = partition haskellish srcs
+
+ haskellish (f,Nothing) =
+ looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
+ haskellish (f,Just phase) =
+ phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
+
+ dflags <- GHC.getSessionDynFlags sess
+ o_files <- mapM (compileFile dflags StopLn) non_hs_srcs
+ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
+
+ targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+ GHC.setTargets sess targets
+ ok_flag <- GHC.load sess LoadAllTargets
when (failed ok_flag) (exitWith (ExitFailure 1))
return ()
-
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
do hPutStr stderr "Glasgow Haskell Compiler, Version "
hPutStr stderr cProjectVersion
hPutStr stderr ", for Haskell 98, compiled by GHC version "
+#ifdef GHCI
+ -- GHCI is only set when we are bootstrapping...
+ hPutStrLn stderr cProjectVersion
+#else
hPutStrLn stderr cBooterVersion
+#endif
showVersion :: IO ()
showVersion = do
exitWith ExitSuccess
where
dump "" = return ()
- dump ('$':'$':s) = hPutStr stderr progName >> dump s
- dump (c:s) = hPutChar stderr c >> dump s
+ dump ('$':'$':s) = putStr progName >> dump s
+ dump (c:s) = putChar c >> dump s
+
+dumpFinalStats :: DynFlags -> IO ()
+dumpFinalStats dflags =
+ when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
+
+dumpFastStringStats :: DynFlags -> IO ()
+dumpFastStringStats dflags = do
+ buckets <- getFastStringTable
+ let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets
+ msg = text "FastString stats:" $$
+ nest 4 (vcat [text "size: " <+> int (length buckets),
+ text "entries: " <+> int entries,
+ text "longest chain: " <+> int longest,
+ text "z-encoded: " <+> (is_z `pcntOf` entries),
+ text "has z-encoding: " <+> (has_z `pcntOf` entries)
+ ])
+ -- we usually get more "has z-encoding" than "z-encoded", because
+ -- when we z-encode a string it might hash to the exact same string,
+ -- which will is not counted as "z-encoded". Only strings whose
+ -- Z-encoding is different from the original string are counted in
+ -- the "z-encoded" total.
+ putMsg dflags msg
+ where
+ x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
+
+countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
+countFS entries longest is_z has_z (b:bs) =
+ let
+ len = length b
+ longest' = max len longest
+ entries' = entries + len
+ is_zs = length (filter isZEncoded b)
+ has_zs = length (filter hasZEncoding b)
+ in
+ countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs
-- -----------------------------------------------------------------------------
-- Util