X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FMain.hs;h=da2a1f2329621b9fab71a448c4434a69ef678d58;hp=bdf9e63e43e6d2e1e6bb3e095286858e4b70fafe;hb=46809fa91667e952afe016e4cd704b21274241b4;hpb=34cc75e1a62638f2833815746ebce0a9114dc26b diff --git a/ghc/Main.hs b/ghc/Main.hs index bdf9e63..da2a1f2 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -12,10 +12,10 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC ( DynFlags(..), HscTarget(..), - GhcMode(..), GhcLink(..), - LoadHowMuch(..), dopt, DynFlag(..), - defaultCallbacks ) +import GHC ( -- DynFlags(..), HscTarget(..), + -- GhcMode(..), GhcLink(..), + Ghc, GhcMonad(..), + LoadHowMuch(..) ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -27,6 +27,7 @@ import DriverMkDepend ( doMkDependHS ) import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) #endif + -- Various other random stuff that we need import Config import HscTypes @@ -45,12 +46,20 @@ import Util import Panic import MonadUtils ( liftIO ) +-- Imports for --abi-hash +import LoadIface ( loadUserInterface ) +import Module ( mkModuleName ) +import Finder ( findImportedModule, cannotFindInterface ) +import TcRnMonad ( initIfaceCheck ) +import Binary ( openBinMem, put_, fingerprintBinMem ) + -- Standard Haskell libraries import System.IO import System.Environment import System.Exit import System.FilePath import Control.Monad +import Data.Char import Data.List import Data.Maybe @@ -67,104 +76,108 @@ import Data.Maybe -- GHC's command-line interface main :: IO () -main = - - GHC.defaultErrorHandler defaultDynFlags $ do - -- 1. extract the -B flag from the args - argv0 <- getArgs +main = do + hSetBuffering stdout NoBuffering + GHC.defaultErrorHandler defaultDynFlags $ do + -- 1. extract the -B flag from the args + argv0 <- getArgs - let - (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 + let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) - let argv1' = map (mkGeneralLocated "on the commandline") argv1 - (argv2, staticFlagWarnings) <- parseStaticFlags argv1' - - -- 2. Parse the "mode" flags (--make, --interactive etc.) - (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 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 - - dflags0 <- GHC.getSessionDynFlags - + let argv1' = map (mkGeneralLocated "on the commandline") argv1 + (argv2, staticFlagWarnings) <- parseStaticFlags argv1' + + -- 2. Parse the "mode" flags (--make, --interactive etc.) + (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + + let flagWarnings = staticFlagWarnings ++ modeFlagWarnings + + -- If all we want to do is something like showing the version number + -- then do it now, before we start a GHC session etc. This makes + -- getting basic information much more resilient. + + -- In particular, if we wait until later before giving the version + -- number 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 mode of + Left preStartupMode -> + do case preStartupMode of + ShowSupportedExtensions -> showSupportedExtensions + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + Print str -> putStrLn str + Right postStartupMode -> + -- start our GHC session + GHC.runGhc mbMinusB $ do + + dflags <- GHC.getSessionDynFlags + + case postStartupMode of + Left preLoadMode -> + liftIO $ do + case preLoadMode of + ShowInfo -> showInfo dflags + ShowGhcUsage -> showGhcUsage dflags + ShowGhciUsage -> showGhciUsage dflags + PrintWithDynFlags f -> putStrLn (f dflags) + Right postLoadMode -> + main' postLoadMode dflags argv3 flagWarnings + +main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String] + -> Ghc () +main' postLoadMode dflags0 args flagWarnings = do -- 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) + = case postLoadMode of + DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) + DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) + DoMake -> (CompManager, dflt_target, LinkBinary) + DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) + DoAbiHash -> (OneShot, dflt_target, LinkBinary) + _ -> (OneShot, dflt_target, LinkBinary) let dflags1 = dflags0{ ghcMode = mode, - hscTarget = lang, + hscTarget = lang, ghcLink = link, - -- leave out hscOutName for now + -- leave out hscOutName for now hscOutName = panic "Main.main:hscOutName not set", - verbosity = case cli_mode of - DoEval _ -> 0 - _other -> 1 - } + verbosity = case postLoadMode 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 + dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled + | DoEval _ <- postLoadMode = 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 + (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a args - -- 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 + let flagWarnings' = flagWarnings ++ dynamicFlagWarnings handleSourceError (\e -> do - GHC.printExceptionAndWarnings e - liftIO $ exitWith (ExitFailure 1)) $ - handleFlagWarnings dflags2 flagWarnings + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ handleFlagWarnings dflags2 flagWarnings' -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do - liftIO $ showBanner cli_mode dflags2 + liftIO $ showBanner postLoadMode dflags2 -- we've finished manipulating the DynFlags, update the session - GHC.setSessionDynFlags dflags2 + _ <- GHC.setSessionDynFlags dflags2 dflags3 <- GHC.getSessionDynFlags hsc_env <- GHC.getSession @@ -187,23 +200,22 @@ main = liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) ---------------- Final sanity checking ----------- - liftIO $ checkOptions cli_mode dflags3 srcs objs + liftIO $ checkOptions postLoadMode dflags3 srcs objs ---------------- Do the business ----------- handleSourceError (\e -> do - GHC.printExceptionAndWarnings e + GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do - case cli_mode of - PrintLibdir -> liftIO $ putStrLn (topDir dflags3) + case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags3 f DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) - StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + StopBefore p -> liftIO (oneShot hsc_env p srcs) DoInteractive -> interactiveUI srcs Nothing DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs + DoAbiHash -> abiHash srcs liftIO $ dumpFinalStats dflags3 - liftIO $ exitWith ExitSuccess #ifndef GHCI interactiveUI :: b -> c -> Ghc () @@ -258,42 +270,42 @@ looks_like_an_input m = isSourceFilename m -- | Ensure sanity of options. -- -- Throws 'UsageError' or 'CmdLineError' if not. -checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () +checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). -checkOptions cli_mode dflags srcs objs = do +checkOptions mode dflags srcs objs = do -- Complain about any unknown flags let unknown_opts = [ f | (f@('-':_), _) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) when (notNull (filter isRTSWay (wayNames dflags)) - && isInterpretiveMode cli_mode) $ + && isInterpretiveMode mode) $ 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)) - && isInterpretiveMode cli_mode) $ + && isInterpretiveMode mode) $ do ghcError (UsageError "--interactive can't be used with -prof or -unreg.") -- -ohi sanity check if (isJust (outputHi dflags) && - (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) + (isCompManagerMode mode || srcs `lengthExceeds` 1)) then ghcError (UsageError "-ohi can only be used when compiling a single source file") else do -- -o sanity checking if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) - && not (isLinkMode cli_mode)) + && not (isLinkMode mode)) then ghcError (UsageError "can't apply -o to multiple source files") else do - let not_linking = not (isLinkMode cli_mode) || isNoLink (ghcLink dflags) + let not_linking = not (isLinkMode 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 || not_linking) && needsInputsMode cli_mode + if null srcs && (null objs || not_linking) && needsInputsMode mode then ghcError (UsageError "no input files") else do @@ -332,38 +344,112 @@ verifyOutputFiles dflags = do ----------------------------------------------------------------------------- -- GHC modes of operation -data UberMode - = ShowUsage -- ghc -? - | ShowVersion -- ghc -V/--version +type Mode = Either PreStartupMode PostStartupMode +type PostStartupMode = Either PreLoadMode PostLoadMode + +data PreStartupMode + = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version - | ShowSupportedLanguages -- ghc --supported-languages - | ShowInfo -- ghc --info - deriving (Show) + | ShowSupportedExtensions -- ghc --supported-extensions + | Print String -- ghc --print-foo + +showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode +showVersionMode = mkPreStartupMode ShowVersion +showNumVersionMode = mkPreStartupMode ShowNumVersion +showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions + +printMode :: String -> Mode +printMode str = mkPreStartupMode (Print str) + +mkPreStartupMode :: PreStartupMode -> Mode +mkPreStartupMode = Left + +isShowVersionMode :: Mode -> Bool +isShowVersionMode (Left ShowVersion) = True +isShowVersionMode _ = False + +isShowNumVersionMode :: Mode -> Bool +isShowNumVersionMode (Left ShowNumVersion) = True +isShowNumVersionMode _ = False + +data PreLoadMode + = ShowGhcUsage -- ghc -? + | ShowGhciUsage -- ghci -? + | ShowInfo -- ghc --info + | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo -data CmdLineMode - = PrintLibdir -- ghc --print-libdir - | ShowInterface String -- ghc --show-iface +showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode +showGhcUsageMode = mkPreLoadMode ShowGhcUsage +showGhciUsageMode = mkPreLoadMode ShowGhciUsage +showInfoMode = mkPreLoadMode ShowInfo + +printWithDynFlagsMode :: (DynFlags -> String) -> Mode +printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f) + +mkPreLoadMode :: PreLoadMode -> Mode +mkPreLoadMode = Right . Left + +isShowGhcUsageMode :: Mode -> Bool +isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True +isShowGhcUsageMode _ = False + +isShowGhciUsageMode :: Mode -> Bool +isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True +isShowGhciUsageMode _ = False + +data PostLoadMode + = ShowInterface FilePath -- 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) + | DoAbiHash -- ghc --abi-hash + +doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode +doMkDependHSMode = mkPostLoadMode DoMkDependHS +doMakeMode = mkPostLoadMode DoMake +doInteractiveMode = mkPostLoadMode DoInteractive +doAbiHashMode = mkPostLoadMode DoAbiHash + +showInterfaceMode :: FilePath -> Mode +showInterfaceMode fp = mkPostLoadMode (ShowInterface fp) + +stopBeforeMode :: Phase -> Mode +stopBeforeMode phase = mkPostLoadMode (StopBefore phase) + +doEvalMode :: String -> Mode +doEvalMode str = mkPostLoadMode (DoEval [str]) + +mkPostLoadMode :: PostLoadMode -> Mode +mkPostLoadMode = Right . Right + +isDoInteractiveMode :: Mode -> Bool +isDoInteractiveMode (Right (Right DoInteractive)) = True +isDoInteractiveMode _ = False + +isStopLnMode :: Mode -> Bool +isStopLnMode (Right (Right (StopBefore StopLn))) = True +isStopLnMode _ = False + +isDoMakeMode :: Mode -> Bool +isDoMakeMode (Right (Right DoMake)) = True +isDoMakeMode _ = False #ifdef GHCI -isInteractiveMode :: CmdLineMode -> Bool +isInteractiveMode :: PostLoadMode -> Bool isInteractiveMode DoInteractive = True isInteractiveMode _ = False #endif -- isInterpretiveMode: byte-code compiler involved -isInterpretiveMode :: CmdLineMode -> Bool +isInterpretiveMode :: PostLoadMode -> Bool isInterpretiveMode DoInteractive = True isInterpretiveMode (DoEval _) = True isInterpretiveMode _ = False -needsInputsMode :: CmdLineMode -> Bool +needsInputsMode :: PostLoadMode -> Bool needsInputsMode DoMkDependHS = True needsInputsMode (StopBefore _) = True needsInputsMode DoMake = True @@ -371,120 +457,134 @@ 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 :: CmdLineMode -> Bool +isLinkMode :: PostLoadMode -> Bool isLinkMode (StopBefore StopLn) = True isLinkMode DoMake = True isLinkMode DoInteractive = True isLinkMode (DoEval _) = True isLinkMode _ = False -isCompManagerMode :: CmdLineMode -> Bool +isCompManagerMode :: PostLoadMode -> Bool isCompManagerMode DoMake = True isCompManagerMode DoInteractive = True isCompManagerMode (DoEval _) = True isCompManagerMode _ = False - -- ----------------------------------------------------------------------------- -- Parsing the mode flag parseModeFlags :: [Located String] - -> IO (Maybe UberMode, - CmdLineMode, + -> IO (Mode, [Located String], [Located String]) parseModeFlags args = do - let ((leftover, errs, warns), (mUberMode, mode, _, flags')) = + let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = runCmdLine (processArgs mode_flags args) - (Nothing, StopBefore StopLn, "", []) + (Nothing, [], []) + mode = case mModeFlag of + Nothing -> doMakeMode + Just (m, _) -> m + errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2 when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (mUberMode, mode, flags' ++ leftover, warns) + return (mode, flags' ++ leftover, warns) -type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, String, [Located String]) +type ModeM = CmdLineP (Maybe (Mode, String), [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 "?" (NoArg (setUberMode ShowUsage)) - Supported - , Flag "-help" (NoArg (setUberMode ShowUsage)) - Supported - , Flag "V" (NoArg (setUberMode ShowVersion)) - Supported - , Flag "-version" (NoArg (setUberMode ShowVersion)) - Supported - , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion)) - Supported - , Flag "-info" (NoArg (setUberMode ShowInfo)) - Supported - , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages)) - Supported - , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) - Supported - + Flag "?" (PassFlag (setMode showGhcUsageMode)) + , Flag "-help" (PassFlag (setMode showGhcUsageMode)) + , Flag "V" (PassFlag (setMode showVersionMode)) + , Flag "-version" (PassFlag (setMode showVersionMode)) + , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) + , Flag "-info" (PassFlag (setMode showInfoMode)) + , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) + , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) + ] ++ + [ Flag k' (PassFlag (setMode mode)) + | (k, v) <- compilerInfo, + let k' = "-print-" ++ map (replaceSpace . toLower) k + replaceSpace ' ' = '-' + replaceSpace c = c + mode = case v of + String str -> printMode str + FromDynFlags f -> printWithDynFlagsMode f + ] ++ ------- interfaces ---------------------------------------------------- - , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f) + [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) - Supported ------- primary modes ------------------------------------------------ - , 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 + , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f + addFlag "-no-link" f)) + , Flag "M" (PassFlag (setMode doMkDependHSMode)) + , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) + , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f + addFlag "-fvia-C" f)) + , Flag "S" (PassFlag (setMode (stopBeforeMode As))) + , Flag "-make" (PassFlag (setMode doMakeMode)) + , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) + , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) + , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) ] -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 - -updateDoEval :: String -> CmdLineMode -> CmdLineMode -updateDoEval expr (DoEval exprs) = DoEval (expr : exprs) -updateDoEval expr _ = DoEval [expr] - -updateMode :: (CmdLineMode -> CmdLineMode) -> String -> ModeM () -updateMode f flag = do - (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 ++ "'")) - -addFlag :: String -> ModeM () -addFlag s = do - (u, m, f, flags') <- getCmdLineState - -- XXX Can we get a useful Loc? - putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags') - +setMode :: Mode -> String -> EwM ModeM () +setMode newMode newFlag = liftEwM $ do + (mModeFlag, errs, flags') <- getCmdLineState + let (modeFlag', errs') = + case mModeFlag of + Nothing -> ((newMode, newFlag), errs) + Just (oldMode, oldFlag) -> + case (oldMode, newMode) of + -- -c/--make are allowed together, and mean --make -no-link + _ | isStopLnMode oldMode && isDoMakeMode newMode + || isStopLnMode newMode && isDoMakeMode oldMode -> + ((doMakeMode, "--make"), []) + + -- If we have both --help and --interactive then we + -- want showGhciUsage + _ | isShowGhcUsageMode oldMode && + isDoInteractiveMode newMode -> + ((showGhciUsageMode, oldFlag), []) + | isShowGhcUsageMode newMode && + isDoInteractiveMode oldMode -> + ((showGhciUsageMode, newFlag), []) + -- Otherwise, --help/--version/--numeric-version always win + | isDominantFlag oldMode -> ((oldMode, oldFlag), []) + | isDominantFlag newMode -> ((newMode, newFlag), []) + -- We need to accumulate eval flags like "-e foo -e bar" + (Right (Right (DoEval esOld)), + Right (Right (DoEval [eNew]))) -> + ((Right (Right (DoEval (eNew : esOld))), oldFlag), + errs) + -- Saying e.g. --interactive --interactive is OK + _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs) + -- Otherwise, complain + _ -> let err = flagMismatchErr oldFlag newFlag + in ((oldMode, oldFlag), err : errs) + putCmdLineState (Just modeFlag', errs', flags') + where isDominantFlag f = isShowGhcUsageMode f || + isShowGhciUsageMode f || + isShowVersionMode f || + isShowNumVersionMode f + +flagMismatchErr :: String -> String -> String +flagMismatchErr oldFlag newFlag + = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" + +addFlag :: String -> String -> EwM ModeM () +addFlag s flag = liftEwM $ do + (m, e, flags') <- getCmdLineState + putCmdLineState (m, e, mkGeneralLocated loc s : flags') + where loc = "addFlag by " ++ flag ++ " on the commandline" -- ---------------------------------------------------------------------------- -- Run --make mode doMake :: [(String,Maybe Phase)] -> Ghc () -doMake [] = ghcError (UsageError "no input files") doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs @@ -494,10 +594,16 @@ doMake srcs = do phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession - o_files <- mapM (\x -> do - f <- compileFile hsc_env StopLn x - GHC.printWarnings - return f) + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot hsc_env StopLn srcs) + else do + + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) non_hs_srcs liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files) @@ -514,59 +620,61 @@ doMake srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv defaultCallbacks dflags + hsc_env <- newHscEnv dflags showIface hsc_env file -- --------------------------------------------------------------------------- -- Various banners and verbosity output. -showBanner :: CmdLineMode -> DynFlags -> IO () -showBanner _cli_mode dflags = do +showBanner :: PostLoadMode -> DynFlags -> IO () +showBanner _postLoadMode dflags = do let verb = verbosity dflags #ifdef GHCI -- Show the GHCi banner - when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg + when (isInteractiveMode _postLoadMode && 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 ", 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 +showInfo :: DynFlags -> IO () +showInfo dflags = do + let sq x = " [" ++ x ++ "\n ]" + putStrLn $ sq $ concat $ intersperse "\n ," $ map (show . flatten) compilerInfo + where flatten (k, String v) = (k, v) + flatten (k, FromDynFlags f) = (k, f dflags) -showSupportedLanguages :: IO () -showSupportedLanguages = do mapM_ putStrLn supportedLanguages - exitWith ExitSuccess +showSupportedExtensions :: IO () +showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions 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 = ghciUsagePath dflags - | otherwise = ghcUsagePath dflags +showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) + +showGhcUsage :: DynFlags -> IO () +showGhcUsage = showUsage False + +showGhciUsage :: DynFlags -> IO () +showGhciUsage = showUsage True + +showUsage :: Bool -> DynFlags -> IO () +showUsage ghci dflags = do + let usage_path = if ghci then ghciUsagePath dflags + else ghcUsagePath dflags usage <- readFile usage_path dump usage - exitWith ExitSuccess where - dump "" = return () + dump "" = return () dump ('$':'$':s) = putStr progName >> dump s - dump (c:s) = putChar c >> dump s + dump (c:s) = putChar c >> dump s dumpFinalStats :: DynFlags -> IO () dumpFinalStats dflags = @@ -605,6 +713,48 @@ countFS entries longest is_z has_z (b:bs) = countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs -- ----------------------------------------------------------------------------- +-- ABI hash support + +{- + ghc --abi-hash Data.Foo System.Bar + +Generates a combined hash of the ABI for modules Data.Foo and +System.Bar. The modules must already be compiled, and appropriate -i +options may be necessary in order to find the .hi files. + +This is used by Cabal for generating the InstalledPackageId for a +package. The InstalledPackageId must change when the visible ABI of +the package chagnes, so during registration Cabal calls ghc --abi-hash +to get a hash of the package's ABI. +-} + +abiHash :: [(String, Maybe Phase)] -> Ghc () +abiHash strs = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + liftIO $ do + + let find_it str = do + let modname = mkModuleName str + r <- findImportedModule hsc_env modname Nothing + case r of + Found _ m -> return m + _error -> ghcError $ CmdLineError $ showSDoc $ + cannotFindInterface dflags modname r + + mods <- mapM find_it (map fst strs) + + let get_iface modl = loadUserInterface False (text "abiHash") modl + ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods + + bh <- openBinMem (3*1024) -- just less than a block + mapM_ (put_ bh . mi_mod_hash) ifaces + f <- fingerprintBinMem bh + + putStrLn (showSDoc (ppr f)) + +-- ----------------------------------------------------------------------------- -- Util unknownFlagsErr :: [String] -> a