X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FMain.hs;h=c078cdb389ebf7fe1e7e4f6c54f84ac2e3a6c5b2;hp=c80ca78a8084cd36e21da7c68b1097098cbe00bd;hb=9d0c8f842e35dde3d570580cf62a32779f66a6de;hpb=c5eedeb72fe656e7bc6c5d21c0a4e91b93f386b6 diff --git a/ghc/Main.hs b/ghc/Main.hs index c80ca78..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 ( DynFlags(..), HscTarget(..), GhcMode(..), GhcLink(..), - LoadHowMuch(..), dopt, DynFlag(..) ) + LoadHowMuch(..), dopt, DynFlag(..), + defaultCallbacks ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -83,23 +82,28 @@ main = (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 GHC.runGhc mbMinusB $ do @@ -140,10 +144,19 @@ main = -- 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 - liftIO $ handleFlagWarnings dflags2 flagWarnings + + handleSourceError (\e -> do + GHC.printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ + handleFlagWarnings dflags2 flagWarnings -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do @@ -151,7 +164,7 @@ main = liftIO $ showBanner cli_mode dflags2 -- we've finished manipulating the DynFlags, update the session - GHC.setSessionDynFlags dflags2 + _ <- GHC.setSessionDynFlags dflags2 dflags3 <- GHC.getSessionDynFlags hsc_env <- GHC.getSession @@ -177,18 +190,11 @@ main = liftIO $ checkOptions cli_mode dflags3 srcs objs ---------------- Do the business ----------- - let alreadyHandled = panic (show cli_mode ++ - " should already have been handled") - handleSourceError (\e -> do GHC.printExceptionAndWarnings e - liftIO $ exitWith (ExitFailure 1)) $ + liftIO $ exitWith (ExitFailure 1)) $ do case cli_mode of - ShowUsage -> liftIO $ showGhcUsage dflags3 cli_mode PrintLibdir -> liftIO $ putStrLn (topDir dflags3) - ShowSupportedLanguages -> alreadyHandled - ShowVersion -> alreadyHandled - ShowNumVersion -> alreadyHandled ShowInterface f -> liftIO $ doShowIface dflags3 f DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) @@ -261,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)) @@ -280,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 @@ -321,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 @@ -360,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 @@ -373,35 +389,39 @@ isCompManagerMode _ = False -- Parsing the mode flag parseModeFlags :: [Located String] - -> IO (CmdLineMode, [Located String], [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, "", []) + let ((leftover, errs, warns), (mUberMode, mode, _, flags')) = + runCmdLine (processArgs mode_flags args) + (Nothing, StopBefore StopLn, "", []) when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (mode, flags' ++ leftover, warns) + return (mUberMode, mode, flags' ++ leftover, warns) -type ModeM = CmdLineP (CmdLineMode, String, [Located 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 ---------------------------------------------------- @@ -433,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 @@ -442,17 +467,17 @@ 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 + (u, m, f, flags') <- getCmdLineState -- XXX Can we get a useful Loc? - putCmdLineState (m, f, mkGeneralLocated "addFlag" s : flags') + putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags') -- ---------------------------------------------------------------------------- @@ -489,7 +514,7 @@ doMake srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv dflags + hsc_env <- newHscEnv defaultCallbacks dflags showIface hsc_env file -- ---------------------------------------------------------------------------