X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FMain.hs;h=c078cdb389ebf7fe1e7e4f6c54f84ac2e3a6c5b2;hp=a2c2fd1a529218f37a16109237e2712d56667c90;hb=9d0c8f842e35dde3d570580cf62a32779f66a6de;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892 diff --git a/ghc/Main.hs b/ghc/Main.hs index a2c2fd1..c078cdb 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -10,13 +10,12 @@ module Main (main) where -#include "HsVersions.h" - -- The official GHC API import qualified GHC -import GHC ( Session, DynFlags(..), HscTarget(..), +import GHC ( DynFlags(..), HscTarget(..), GhcMode(..), GhcLink(..), - LoadHowMuch(..), dopt, DynFlag(..) ) + LoadHowMuch(..), dopt, DynFlag(..), + defaultCallbacks ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -34,14 +33,17 @@ import HscTypes import Packages ( dumpPackages ) import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) +import BasicTypes ( failed ) import StaticFlags +import StaticFlagParser import DynFlags -import BasicTypes ( failed ) import ErrUtils import FastString import Outputable +import SrcLoc import Util import Panic +import MonadUtils ( liftIO ) -- Standard Haskell libraries import System.IO @@ -66,8 +68,8 @@ import Data.Maybe main :: IO () main = - GHC.defaultErrorHandler defaultDynFlags $ do + GHC.defaultErrorHandler defaultDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -76,31 +78,37 @@ main = mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) - (argv2, staticFlagWarnings) <- parseStaticFlags argv1 + let argv1' = map (mkGeneralLocated "on the commandline") argv1 + (argv2, staticFlagWarnings) <- parseStaticFlags argv1' -- 2. Parse the "mode" flags (--make, --interactive etc.) - (cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + (m_uber_mode, 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. -- If we do it later then bootstrapping gets confused as it tries -- to find out what version of GHC it's using before package.conf -- exists, so starting the session fails. - case cli_mode of - ShowInfo -> do showInfo - exitWith ExitSuccess - ShowSupportedLanguages -> do showSupportedLanguages - exitWith ExitSuccess - ShowVersion -> do showVersion - exitWith ExitSuccess - ShowNumVersion -> do putStrLn cProjectVersion - exitWith ExitSuccess - _ -> return () + case m_uber_mode of + -- ShowUsage currently has to be handled specially, as it needs to + -- actually start up GHC so that it can find the usage.txt files + -- in the libdir. It would be nice to embed the text in the + -- executable so that we don't have to do that, and things are more + -- uniform here. + Just ShowUsage -> return () + Just um -> + do case um of + ShowInfo -> showInfo + ShowSupportedLanguages -> showSupportedLanguages + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + exitWith ExitSuccess + Nothing -> return () -- start our GHC session - session <- GHC.newSession mbMinusB + GHC.runGhc mbMinusB $ do - dflags0 <- GHC.getSessionDynFlags session + dflags0 <- GHC.getSessionDynFlags -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only @@ -109,84 +117,97 @@ main = 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) + 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 - DoEval _ -> 0 - _other -> 1 - } - - -- The rest of the arguments are "dynamic" - -- Leftover ones are presumably files - (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1 argv3 + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + verbosity = case cli_mode of + DoEval _ -> 0 + _other -> 1 + } + + -- turn on -fimplicit-import-qualified for GHCi now, so that it + -- can be overriden from the command-line + dflags1a | DoInteractive <- cli_mode = imp_qual_enabled + | DoEval _ <- cli_mode = imp_qual_enabled + | otherwise = dflags1 + where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified + + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files + (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3 + + -- As noted earlier, currently we hvae to handle ShowUsage down here + case m_uber_mode of + Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode + _ -> return () let flagWarnings = staticFlagWarnings ++ modeFlagWarnings ++ dynamicFlagWarnings - handleFlagWarnings dflags2 flagWarnings - -- make sure we clean up after ourselves + handleSourceError (\e -> do + GHC.printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ + handleFlagWarnings dflags2 flagWarnings + + -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do - showBanner cli_mode dflags2 + liftIO $ showBanner cli_mode dflags2 -- we've finished manipulating the DynFlags, update the session - GHC.setSessionDynFlags session dflags2 - dflags3 <- GHC.getSessionDynFlags session - hsc_env <- GHC.sessionHscEnv session + _ <- GHC.setSessionDynFlags dflags2 + dflags3 <- GHC.getSessionDynFlags + hsc_env <- GHC.getSession 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 normalise fileish_args + normal_fileish_paths = map (normalise . unLoc) fileish_args (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) + liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse objs) - ---------------- Display configuration ----------- + ---------------- Display configuration ----------- when (verbosity dflags3 >= 4) $ - dumpPackages dflags3 + liftIO $ dumpPackages dflags3 when (verbosity dflags3 >= 3) $ do - hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) + liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) - ---------------- Final sanity checking ----------- - checkOptions cli_mode dflags3 srcs objs + ---------------- Final sanity checking ----------- + liftIO $ checkOptions cli_mode dflags3 srcs objs ---------------- Do the business ----------- - let alreadyHandled = panic (show cli_mode ++ - " should already have been handled") - case cli_mode of - 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 + handleSourceError (\e -> do + GHC.printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ do + case cli_mode of + PrintLibdir -> liftIO $ putStrLn (topDir dflags3) + ShowInterface f -> liftIO $ doShowIface dflags3 f + DoMake -> doMake srcs + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + DoInteractive -> interactiveUI srcs Nothing + DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs + + liftIO $ dumpFinalStats dflags3 + liftIO $ exitWith ExitSuccess #ifndef GHCI -interactiveUI :: a -> b -> c -> IO () -interactiveUI _ _ _ = +interactiveUI :: b -> c -> Ghc () +interactiveUI _ _ = ghcError (CmdLineError "not built for interactive use") #endif @@ -234,6 +255,9 @@ looks_like_an_input m = isSourceFilename m -- ----------------------------------------------------------------------------- -- Option sanity checks +-- | Ensure sanity of options. +-- +-- Throws 'UsageError' or 'CmdLineError' if not. checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). checkOptions cli_mode dflags srcs objs = do @@ -243,7 +267,7 @@ checkOptions cli_mode dflags srcs objs = do when (notNull (filter isRTSWay (wayNames dflags)) && isInterpretiveMode cli_mode) $ - putStrLn ("Warning: -debug, -threaded and -ticky are ignored by GHCi") + hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") -- -prof and --interactive are not a good combination when (notNull (filter (not . isRTSWay) (wayNames dflags)) @@ -262,9 +286,14 @@ checkOptions cli_mode dflags srcs objs = do then ghcError (UsageError "can't apply -o to multiple source files") else do + let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags) + + when (not_linking && not (null objs)) $ + hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) + -- Check that there are some input files -- (except in the interactive case) - if null srcs && null objs && needsInputsMode cli_mode + if null srcs && (null objs || not_linking) && needsInputsMode cli_mode then ghcError (UsageError "no input files") else do @@ -303,13 +332,16 @@ verifyOutputFiles dflags = do ----------------------------------------------------------------------------- -- GHC modes of operation -data CmdLineMode +data UberMode = ShowUsage -- ghc -? - | PrintLibdir -- ghc --print-libdir - | ShowInfo -- ghc --info - | ShowSupportedLanguages -- ghc --supported-languages | ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version + | ShowSupportedLanguages -- ghc --supported-languages + | ShowInfo -- ghc --info + deriving (Show) + +data CmdLineMode + = PrintLibdir -- ghc --print-libdir | ShowInterface String -- ghc --show-iface | DoMkDependHS -- ghc -M | StopBefore Phase -- ghc -E | -C | -S @@ -342,6 +374,8 @@ needsInputsMode _ = False isLinkMode :: CmdLineMode -> Bool isLinkMode (StopBefore StopLn) = True isLinkMode DoMake = True +isLinkMode DoInteractive = True +isLinkMode (DoEval _) = True isLinkMode _ = False isCompManagerMode :: CmdLineMode -> Bool @@ -354,36 +388,40 @@ isCompManagerMode _ = False -- ----------------------------------------------------------------------------- -- Parsing the mode flag -parseModeFlags :: [String] -> IO (CmdLineMode, [String], [String]) +parseModeFlags :: [Located String] + -> IO (Maybe UberMode, + CmdLineMode, + [Located String], + [Located String]) parseModeFlags args = do - let ((leftover, errs, warns), (mode, _, flags')) = - runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", []) - when (not (null errs)) $ do - ghcError (UsageError (unlines errs)) - return (mode, flags' ++ leftover, warns) + let ((leftover, errs, warns), (mUberMode, mode, _, flags')) = + runCmdLine (processArgs mode_flags args) + (Nothing, StopBefore StopLn, "", []) + when (not (null errs)) $ ghcError $ errorsToGhcException errs + return (mUberMode, mode, flags' ++ leftover, warns) -type ModeM = CmdLineP (CmdLineMode, String, [String]) +type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String]) -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) -- so we collect the new ones and return them. mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- - Flag "?" (PassFlag (setMode ShowUsage)) + Flag "?" (NoArg (setUberMode ShowUsage)) Supported - , Flag "-help" (PassFlag (setMode ShowUsage)) + , Flag "-help" (NoArg (setUberMode ShowUsage)) Supported - , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) + , Flag "V" (NoArg (setUberMode ShowVersion)) Supported - , Flag "V" (PassFlag (setMode ShowVersion)) + , Flag "-version" (NoArg (setUberMode ShowVersion)) Supported - , Flag "-version" (PassFlag (setMode ShowVersion)) + , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion)) Supported - , Flag "-numeric-version" (PassFlag (setMode ShowNumVersion)) + , Flag "-info" (NoArg (setUberMode ShowInfo)) Supported - , Flag "-info" (PassFlag (setMode ShowInfo)) + , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages)) Supported - , Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages)) + , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) Supported ------- interfaces ---------------------------------------------------- @@ -415,6 +453,11 @@ mode_flags = Supported ] +setUberMode :: UberMode -> ModeM () +setUberMode m = do + (_, cmdLineMode, flag, flags') <- getCmdLineState + putCmdLineState (Just m, cmdLineMode, flag, flags') + setMode :: CmdLineMode -> String -> ModeM () setMode m flag = updateMode (\_ -> m) flag @@ -424,24 +467,25 @@ 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 ghcError (UsageError + (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState + if null old_flag || flag == old_flag + then putCmdLineState (m_uber_mode, f old_mode, flag, flags') + else ghcError (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') + (u, m, f, flags') <- getCmdLineState + -- XXX Can we get a useful Loc? + putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags') -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: Session -> [(String,Maybe Phase)] -> IO () -doMake _ [] = ghcError (UsageError "no input files") -doMake sess srcs = do +doMake :: [(String,Maybe Phase)] -> Ghc () +doMake [] = ghcError (UsageError "no input files") +doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = @@ -449,14 +493,19 @@ doMake sess srcs = do haskellish (_,Just phase) = phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] - hsc_env <- GHC.sessionHscEnv sess - o_files <- mapM (compileFile hsc_env StopLn) non_hs_srcs - mapM_ (consIORef v_Ld_inputs) (reverse o_files) + hsc_env <- GHC.getSession + o_files <- mapM (\x -> do + f <- compileFile hsc_env StopLn x + GHC.printWarnings + return f) + non_hs_srcs + liftIO $ 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)) + GHC.setTargets targets + ok_flag <- GHC.load LoadAllTargets + + when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) return () @@ -465,7 +514,7 @@ doMake sess srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv dflags + hsc_env <- newHscEnv defaultCallbacks dflags showIface hsc_env file -- ---------------------------------------------------------------------------