X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FMain.hs;h=da2a1f2329621b9fab71a448c4434a69ef678d58;hp=a2c2fd1a529218f37a16109237e2712d56667c90;hb=46809fa91667e952afe016e4cd704b21274241b4;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892 diff --git a/ghc/Main.hs b/ghc/Main.hs index a2c2fd1..da2a1f2 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(..), - GhcMode(..), GhcLink(..), - LoadHowMuch(..), dopt, DynFlag(..) ) +import GHC ( -- DynFlags(..), HscTarget(..), + -- GhcMode(..), GhcLink(..), + Ghc, GhcMonad(..), + LoadHowMuch(..) ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -28,20 +27,31 @@ import DriverMkDepend ( doMkDependHS ) import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) #endif + -- Various other random stuff that we need import Config 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 ) + +-- 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 @@ -49,6 +59,7 @@ import System.Environment import System.Exit import System.FilePath import Control.Monad +import Data.Char import Data.List import Data.Maybe @@ -65,128 +76,150 @@ 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)) - (argv2, staticFlagWarnings) <- parseStaticFlags argv1 - - -- 2. Parse the "mode" flags (--make, --interactive etc.) - (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 () - - -- start our GHC session - session <- GHC.newSession mbMinusB - - dflags0 <- GHC.getSessionDynFlags session - + 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 - 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 - - let flagWarnings = staticFlagWarnings - ++ modeFlagWarnings - ++ dynamicFlagWarnings - handleFlagWarnings dflags2 flagWarnings - - -- make sure we clean up after ourselves + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + 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 <- 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 args + + let flagWarnings' = flagWarnings ++ dynamicFlagWarnings + + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ handleFlagWarnings dflags2 flagWarnings' + + -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do - showBanner cli_mode dflags2 + liftIO $ showBanner postLoadMode 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 postLoadMode 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.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + case postLoadMode of + ShowInterface f -> liftIO $ doShowIface dflags3 f + DoMake -> doMake srcs + DoMkDependHS -> doMkDependHS (map fst srcs) + 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 #ifndef GHCI -interactiveUI :: a -> b -> c -> IO () -interactiveUI _ _ _ = +interactiveUI :: b -> c -> Ghc () +interactiveUI _ _ = ghcError (CmdLineError "not built for interactive use") #endif @@ -234,37 +267,45 @@ looks_like_an_input m = isSourceFilename m -- ----------------------------------------------------------------------------- -- Option sanity checks -checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () +-- | Ensure sanity of options. +-- +-- Throws 'UsageError' or 'CmdLineError' if not. +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) $ - putStrLn ("Warning: -debug, -threaded and -ticky are ignored by GHCi") + && 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 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 mode then ghcError (UsageError "no input files") else do @@ -303,35 +344,112 @@ verifyOutputFiles dflags = do ----------------------------------------------------------------------------- -- GHC modes of operation -data CmdLineMode - = ShowUsage -- ghc -? - | PrintLibdir -- ghc --print-libdir - | ShowInfo -- ghc --info - | ShowSupportedLanguages -- ghc --supported-languages - | ShowVersion -- ghc -V/--version +type Mode = Either PreStartupMode PostStartupMode +type PostStartupMode = Either PreLoadMode PostLoadMode + +data PreStartupMode + = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version - | ShowInterface String -- ghc --show-iface + | 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 + +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 @@ -339,109 +457,135 @@ 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 :: [String] -> IO (CmdLineMode, [String], [String]) +parseModeFlags :: [Located String] + -> IO (Mode, + [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)) + let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = + runCmdLine (processArgs mode_flags args) + (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 (mode, flags' ++ leftover, warns) -type ModeM = CmdLineP (CmdLineMode, String, [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 "?" (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 - + 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")) ] -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 - (old_mode, old_flag, flags') <- getCmdLineState - if notNull old_flag && flag /= old_flag - then 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') - +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 :: Session -> [(String,Maybe Phase)] -> IO () -doMake _ [] = ghcError (UsageError "no input files") -doMake sess srcs = do +doMake :: [(String,Maybe Phase)] -> Ghc () +doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = @@ -449,14 +593,25 @@ 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 + + -- 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) 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 () @@ -471,53 +626,55 @@ doShowIface dflags file = do -- --------------------------------------------------------------------------- -- 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 = @@ -556,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