{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+
-----------------------------------------------------------------------------
--
-- GHC Driver program
-- The official GHC API
import qualified GHC
-import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..),
+import GHC ( Session, DynFlags(..), HscTarget(..),
+ GhcMode(..), GhcLink(..),
LoadHowMuch(..), dopt, DynFlag(..) )
import CmdLineParser
import DriverPipeline ( oneShot, compileFile )
import DriverMkDepend ( doMkDependHS )
#ifdef GHCI
-import InteractiveUI ( ghciWelcomeMsg, interactiveUI )
+import InteractiveUI ( interactiveUI, ghciWelcomeMsg )
#endif
-- Various other random stuff that we need
-import Config ( cProjectVersion, cBooterVersion, cProjectName )
+import Config
+import HscTypes
import Packages ( dumpPackages )
import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
startPhase, isHaskellSrcFilename )
import StaticFlags
-import DynFlags ( defaultDynFlags )
+import DynFlags
import BasicTypes ( failed )
-import ErrUtils ( putMsg )
-import FastString ( getFastStringTable, isZEncoded, hasZEncoding )
+import ErrUtils
+import FastString
import Outputable
import Util
import Panic
import System.Directory ( doesDirectoryExist )
import System.Environment
import System.Exit
+import System.FilePath
import Control.Monad
import Data.List
import Data.Maybe
-----------------------------------------------------------------------------
-- GHC's command-line interface
+main :: IO ()
main =
GHC.defaultErrorHandler defaultDynFlags $ do
argv0 <- getArgs
let
- (minusB_args, argv1) = partition (prefixMatch "-B") argv0
+ (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
mbMinusB | null minusB_args = Nothing
| otherwise = Just (drop 2 (last minusB_args))
- argv2 <- parseStaticFlags argv1
+ (argv2, staticFlagWarnings) <- parseStaticFlags argv1
-- 2. Parse the "mode" flags (--make, --interactive etc.)
- (cli_mode, argv3) <- parseModeFlags argv2
+ (cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
-- If all we want to do is to show the version number then do it
-- now, before we start a GHC session etc.
-- to find out what version of GHC it's using before package.conf
-- exists, so starting the session fails.
case cli_mode of
- ShowVersion -> do showVersion
- exitWith ExitSuccess
- ShowNumVersion -> do putStrLn cProjectVersion
- exitWith ExitSuccess
- _ -> return ()
-
- let mode = case cli_mode of
- DoInteractive -> Interactive
- DoEval _ -> Interactive
- DoMake -> BatchCompile
- DoMkDependHS -> MkDepend
- _ -> OneShot
+ ShowInfo -> do showInfo
+ exitWith ExitSuccess
+ ShowSupportedLanguages -> do showSupportedLanguages
+ exitWith ExitSuccess
+ ShowVersion -> do showVersion
+ exitWith ExitSuccess
+ ShowNumVersion -> do putStrLn cProjectVersion
+ exitWith ExitSuccess
+ _ -> return ()
-- start our GHC session
- session <- GHC.newSession mode mbMinusB
+ session <- GHC.newSession mbMinusB
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,
+ -- set the default GhcMode, HscTarget and GhcLink. 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 dflt_target = hscTarget dflags0
+ (mode, lang, link)
+ = case cli_mode of
+ DoInteractive -> (CompManager, HscInterpreted, LinkInMemory)
+ DoEval _ -> (CompManager, HscInterpreted, LinkInMemory)
+ DoMake -> (CompManager, dflt_target, LinkBinary)
+ DoMkDependHS -> (MkDepend, dflt_target, LinkBinary)
+ _ -> (OneShot, dflt_target, LinkBinary)
+
+ let dflags1 = dflags0{ ghcMode = mode,
+ hscTarget = lang,
+ ghcLink = link,
-- leave out hscOutName for now
hscOutName = panic "Main.main:hscOutName not set",
verbosity = case cli_mode of
-- The rest of the arguments are "dynamic"
-- Leftover ones are presumably files
- (dflags, fileish_args) <- GHC.parseDynamicFlags dflags1 argv3
+ (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1 argv3
+
+ let flagWarnings = staticFlagWarnings
+ ++ modeFlagWarnings
+ ++ dynamicFlagWarnings
+ handleFlagWarnings dflags2 flagWarnings
-- make sure we clean up after ourselves
- GHC.defaultCleanupHandler dflags $ do
+ GHC.defaultCleanupHandler dflags2 $ do
- -- Display banner
- showBanner cli_mode dflags
+ showBanner cli_mode dflags2
-- we've finished manipulating the DynFlags, update the session
- GHC.setSessionDynFlags session dflags
- dflags <- GHC.getSessionDynFlags session
+ GHC.setSessionDynFlags session dflags2
+ dflags3 <- GHC.getSessionDynFlags session
+ hsc_env <- GHC.sessionHscEnv session
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
+ normal_fileish_paths = map normalise fileish_args
(srcs, objs) = partition_args normal_fileish_paths [] []
-- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
mapM_ (consIORef v_Ld_inputs) (reverse objs)
---------------- Display configuration -----------
- when (verbosity dflags >= 4) $
- dumpPackages dflags
+ when (verbosity dflags3 >= 4) $
+ dumpPackages dflags3
- when (verbosity dflags >= 3) $ do
+ when (verbosity dflags3 >= 3) $ do
hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)
---------------- Final sanity checking -----------
- checkOptions cli_mode dflags srcs objs
+ checkOptions cli_mode dflags3 srcs objs
- ---------------- Do the business -----------
+ ---------------- Do the business -----------
+ let alreadyHandled = panic (show cli_mode ++
+ " should already have been handled")
case cli_mode of
- ShowUsage -> showGhcUsage dflags cli_mode
- PrintLibdir -> putStrLn (topDir dflags)
- ShowVersion -> panic "ShowVersion should already have been handled"
- ShowNumVersion -> panic "ShowNumVersion should already have been handled"
- ShowInterface f -> doShowIface dflags f
- DoMake -> doMake session srcs
- DoMkDependHS -> doMkDependHS session (map fst srcs)
- StopBefore p -> oneShot dflags p srcs
- DoInteractive -> interactiveUI session srcs Nothing
- DoEval expr -> interactiveUI session srcs (Just expr)
-
- dumpFinalStats dflags
+ ShowUsage -> showGhcUsage dflags3 cli_mode
+ PrintLibdir -> putStrLn (topDir dflags3)
+ ShowSupportedLanguages -> alreadyHandled
+ ShowVersion -> alreadyHandled
+ ShowNumVersion -> alreadyHandled
+ ShowInterface f -> doShowIface dflags3 f
+ DoMake -> doMake session srcs
+ DoMkDependHS -> doMkDependHS session (map fst srcs)
+ StopBefore p -> oneShot hsc_env p srcs
+ DoInteractive -> interactiveUI session srcs Nothing
+ DoEval exprs -> interactiveUI session srcs $ Just $ reverse exprs
+
+ dumpFinalStats dflags3
exitWith ExitSuccess
#ifndef GHCI
+interactiveUI :: a -> b -> c -> IO ()
interactiveUI _ _ _ =
throwDyn (CmdLineError "not built for interactive use")
#endif
-- 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 :: [String] -> [(String, Maybe Phase)] -> [String]
+ -> ([(String, Maybe Phase)], [String])
partition_args [] srcs objs = (reverse srcs, reverse objs)
partition_args ("-x":suff:args) srcs objs
| "none" <- suff = partition_args args srcs objs
Everything else is considered to be a linker object, and passed
straight through to the linker.
-}
+looks_like_an_input :: String -> Bool
looks_like_an_input m = isSourceFilename m
|| looksLikeModuleName m
|| '.' `notElem` m
let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
+ when (notNull (filter isRTSWay (wayNames dflags))
+ && isInterpretiveMode cli_mode) $
+ putStrLn ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
+
-- -prof and --interactive are not a good combination
- when (notNull (filter (/= WayThreaded) (wayNames dflags))
+ when (notNull (filter (not . isRTSWay) (wayNames dflags))
&& isInterpretiveMode cli_mode) $
do throwDyn (UsageError
- "--interactive can't be used with -prof, -ticky, or -unreg.")
+ "--interactive can't be used with -prof or -unreg.")
-- -ohi sanity check
if (isJust (outputHi dflags) &&
(isCompManagerMode cli_mode || srcs `lengthExceeds` 1))
-- GHC modes of operation
data CmdLineMode
- = ShowUsage -- ghc -?
- | PrintLibdir -- ghc --print-libdir
- | ShowVersion -- ghc -V/--version
- | ShowNumVersion -- ghc --numeric-version
- | ShowInterface String -- ghc --show-iface
- | DoMkDependHS -- ghc -M
- | StopBefore Phase -- ghc -E | -C | -S
- -- StopBefore StopLn is the default
- | DoMake -- ghc --make
- | DoInteractive -- ghc --interactive
- | DoEval String -- ghc -e
+ = ShowUsage -- ghc -?
+ | PrintLibdir -- ghc --print-libdir
+ | ShowInfo -- ghc --info
+ | ShowSupportedLanguages -- ghc --supported-languages
+ | ShowVersion -- ghc -V/--version
+ | ShowNumVersion -- ghc --numeric-version
+ | ShowInterface String -- ghc --show-iface
+ | DoMkDependHS -- ghc -M
+ | StopBefore Phase -- ghc -E | -C | -S
+ -- StopBefore StopLn is the default
+ | DoMake -- ghc --make
+ | DoInteractive -- ghc --interactive
+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
deriving (Show)
-isInteractiveMode, isInterpretiveMode :: CmdLineMode -> Bool
-isLinkMode, isCompManagerMode :: CmdLineMode -> Bool
-
+#ifdef GHCI
+isInteractiveMode :: CmdLineMode -> Bool
isInteractiveMode DoInteractive = True
isInteractiveMode _ = False
+#endif
-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: CmdLineMode -> Bool
isInterpretiveMode DoInteractive = True
isInterpretiveMode (DoEval _) = True
isInterpretiveMode _ = False
+needsInputsMode :: CmdLineMode -> Bool
needsInputsMode DoMkDependHS = True
needsInputsMode (StopBefore _) = True
needsInputsMode DoMake = True
-- True if we are going to attempt to link in this mode.
-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: CmdLineMode -> Bool
isLinkMode (StopBefore StopLn) = True
isLinkMode DoMake = True
isLinkMode _ = False
+isCompManagerMode :: CmdLineMode -> Bool
isCompManagerMode DoMake = True
isCompManagerMode DoInteractive = True
isCompManagerMode (DoEval _) = True
-- -----------------------------------------------------------------------------
-- Parsing the mode flag
-parseModeFlags :: [String] -> IO (CmdLineMode, [String])
+parseModeFlags :: [String] -> IO (CmdLineMode, [String], [String])
parseModeFlags args = do
- let ((leftover, errs), (mode, _, flags)) =
+ let ((leftover, errs, warns), (mode, _, flags')) =
runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", [])
when (not (null errs)) $ do
throwDyn (UsageError (unlines errs))
- return (mode, flags ++ leftover)
+ return (mode, flags' ++ leftover, warns)
-type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
+type ModeM = CmdLineP (CmdLineMode, String, [String])
-- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
-- so we collect the new ones and return them.
-mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
+mode_flags :: [Flag ModeM]
mode_flags =
[ ------- help / version ----------------------------------------------
- ( "?" , PassFlag (setMode ShowUsage))
- , ( "-help" , PassFlag (setMode ShowUsage))
- , ( "-print-libdir" , PassFlag (setMode PrintLibdir))
- , ( "V" , PassFlag (setMode ShowVersion))
- , ( "-version" , PassFlag (setMode ShowVersion))
- , ( "-numeric-version", PassFlag (setMode ShowNumVersion))
+ Flag "?" (PassFlag (setMode ShowUsage))
+ Supported
+ , Flag "-help" (PassFlag (setMode ShowUsage))
+ Supported
+ , Flag "-print-libdir" (PassFlag (setMode PrintLibdir))
+ Supported
+ , Flag "V" (PassFlag (setMode ShowVersion))
+ Supported
+ , Flag "-version" (PassFlag (setMode ShowVersion))
+ Supported
+ , Flag "-numeric-version" (PassFlag (setMode ShowNumVersion))
+ Supported
+ , Flag "-info" (PassFlag (setMode ShowInfo))
+ Supported
+ , Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages))
+ Supported
------- interfaces ----------------------------------------------------
- , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f)
- "--show-iface"))
+ , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f)
+ "--show-iface"))
+ Supported
------- primary modes ------------------------------------------------
- , ( "M" , PassFlag (setMode DoMkDependHS))
- , ( "E" , PassFlag (setMode (StopBefore anyHsc)))
- , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f
- addFlag "-fvia-C"))
- , ( "S" , PassFlag (setMode (StopBefore As)))
- , ( "-make" , PassFlag (setMode DoMake))
- , ( "-interactive" , PassFlag (setMode DoInteractive))
- , ( "e" , HasArg (\s -> setMode (DoEval s) "-e"))
-
- -- -fno-code says to stop after Hsc but don't generate any code.
- , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f
- addFlag "-fno-code"
- addFlag "-no-recomp"))
+ , Flag "M" (PassFlag (setMode DoMkDependHS))
+ Supported
+ , Flag "E" (PassFlag (setMode (StopBefore anyHsc)))
+ Supported
+ , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f
+ addFlag "-fvia-C"))
+ Supported
+ , Flag "S" (PassFlag (setMode (StopBefore As)))
+ Supported
+ , Flag "-make" (PassFlag (setMode DoMake))
+ Supported
+ , Flag "-interactive" (PassFlag (setMode DoInteractive))
+ Supported
+ , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e"))
+ Supported
+
+ -- -fno-code says to stop after Hsc but don't generate any code.
+ , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f
+ addFlag "-fno-code"
+ addFlag "-fforce-recomp"))
+ Supported
]
setMode :: CmdLineMode -> String -> ModeM ()
-setMode m flag = do
- (old_mode, old_flag, flags) <- getCmdLineState
- when (notNull old_flag && flag /= old_flag) $
- throwDyn (UsageError
- ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
- putCmdLineState (m, flag, flags)
+setMode m flag = updateMode (\_ -> m) flag
+
+updateDoEval :: String -> CmdLineMode -> CmdLineMode
+updateDoEval expr (DoEval exprs) = DoEval (expr : exprs)
+updateDoEval expr _ = DoEval [expr]
+
+updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM ()
+updateMode f flag = do
+ (old_mode, old_flag, flags') <- getCmdLineState
+ if notNull old_flag && flag /= old_flag
+ then throwDyn (UsageError
+ ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
+ else putCmdLineState (f old_mode, flag, flags')
addFlag :: String -> ModeM ()
addFlag s = do
- (m, f, flags) <- getCmdLineState
- putCmdLineState (m, f, s:flags)
+ (m, f, flags') <- getCmdLineState
+ putCmdLineState (m, f, s:flags')
-- ----------------------------------------------------------------------------
-- Run --make mode
doMake :: Session -> [(String,Maybe Phase)] -> IO ()
-doMake sess [] = throwDyn (UsageError "no input files")
+doMake _ [] = 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) =
+ haskellish (_,Just phase) =
phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
- dflags <- GHC.getSessionDynFlags sess
- o_files <- mapM (compileFile dflags StopLn) non_hs_srcs
+ hsc_env <- GHC.sessionHscEnv sess
+ o_files <- mapM (compileFile hsc_env StopLn) non_hs_srcs
mapM_ (consIORef v_Ld_inputs) (reverse o_files)
targets <- mapM (uncurry GHC.guessTarget) hs_srcs
-- Various banners and verbosity output.
showBanner :: CmdLineMode -> DynFlags -> IO ()
-showBanner cli_mode dflags = do
+showBanner _cli_mode dflags = do
let verb = verbosity dflags
- -- Show the GHCi banner
-# ifdef GHCI
- when (isInteractiveMode cli_mode && verb >= 1) $
- hPutStrLn stdout ghciWelcomeMsg
-# endif
-
- -- Display details of the configuration in verbose mode
- when (not (isInteractiveMode cli_mode) && verb >= 2) $
- 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
+ -- Show the GHCi banner
+ when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg
#endif
+ -- Display details of the configuration in verbose mode
+ when (verb >= 2) $
+ do hPutStr stderr "Glasgow Haskell Compiler, Version "
+ hPutStr stderr cProjectVersion
+ hPutStr stderr ", for Haskell 98, stage "
+ hPutStr stderr cStage
+ hPutStr stderr " booted by GHC version "
+ hPutStrLn stderr cBooterVersion
+
+-- We print out a Read-friendly string, but a prettier one than the
+-- Show instance gives us
+showInfo :: IO ()
+showInfo = do
+ let sq x = " [" ++ x ++ "\n ]"
+ putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo
+ exitWith ExitSuccess
+
+showSupportedLanguages :: IO ()
+showSupportedLanguages = do mapM_ putStrLn supportedLanguages
+ exitWith ExitSuccess
+
showVersion :: IO ()
showVersion = do
putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
exitWith ExitSuccess
+showGhcUsage :: DynFlags -> CmdLineMode -> IO ()
showGhcUsage dflags cli_mode = do
let usage_path
- | DoInteractive <- cli_mode = ghcUsagePath dflags
- | otherwise = ghciUsagePath dflags
+ | DoInteractive <- cli_mode = ghciUsagePath dflags
+ | otherwise = ghcUsagePath dflags
usage <- readFile usage_path
dump usage
exitWith ExitSuccess
putMsg dflags msg
where
x `pcntOf` y = int ((x * 100) `quot` y) <> char '%'
-
+
+countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int)
countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z)
countFS entries longest is_z has_z (b:bs) =
let