X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FMain.hs;h=fab773ba95771c608e6bf95637ee1ee79ca110d2;hb=cfb69428a10e245bc5b64417803b637693977b24;hp=22275e2dfe7064747450702f945a7b0a50fdbc05;hpb=1c1980863810c6b1bbed2ebbcce882a0f9144ade;p=ghc-hetmet.git diff --git a/ghc/Main.hs b/ghc/Main.hs index 22275e2..fab773b 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -27,6 +27,7 @@ import DriverMkDepend ( doMkDependHS ) import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) #endif + -- Various other random stuff that we need import Config import HscTypes @@ -45,6 +46,13 @@ 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 @@ -68,8 +76,9 @@ import Data.Maybe -- GHC's command-line interface main :: IO () -main = - GHC.defaultErrorHandler defaultDynFlags $ do +main = do + hSetBuffering stdout NoBuffering + GHC.defaultErrorHandler defaultDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -96,7 +105,7 @@ main = case mode of Left preStartupMode -> do case preStartupMode of - ShowSupportedLanguages -> showSupportedLanguages + ShowSupportedExtensions -> showSupportedExtensions ShowVersion -> showVersion ShowNumVersion -> putStrLn cProjectVersion Print str -> putStrLn str @@ -131,6 +140,7 @@ main' postLoadMode dflags0 args flagWarnings = do 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, @@ -199,10 +209,12 @@ main' postLoadMode dflags0 args flagWarnings = do case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags3 f DoMake -> doMake srcs - DoMkDependHS -> doMkDependHS (map fst srcs) + DoMkDependHS -> do doMkDependHS (map fst srcs) + GHC.printWarnings StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings DoInteractive -> interactiveUI srcs Nothing DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs + DoAbiHash -> abiHash srcs liftIO $ dumpFinalStats dflags3 @@ -339,13 +351,13 @@ type PostStartupMode = Either PreLoadMode PostLoadMode data PreStartupMode = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version - | ShowSupportedLanguages -- ghc --supported-languages + | ShowSupportedExtensions -- ghc --supported-extensions | Print String -- ghc --print-foo -showVersionMode, showNumVersionMode, showSupportedLanguagesMode :: Mode -showVersionMode = mkPreStartupMode ShowVersion -showNumVersionMode = mkPreStartupMode ShowNumVersion -showSupportedLanguagesMode = mkPreStartupMode ShowSupportedLanguages +showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode +showVersionMode = mkPreStartupMode ShowVersion +showNumVersionMode = mkPreStartupMode ShowNumVersion +showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions printMode :: String -> Mode printMode str = mkPreStartupMode (Print str) @@ -394,11 +406,13 @@ data PostLoadMode | DoMake -- ghc --make | DoInteractive -- ghc --interactive | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] + | DoAbiHash -- ghc --abi-hash -doMkDependHSMode, doMakeMode, doInteractiveMode :: Mode +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) @@ -416,6 +430,14 @@ 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 :: PostLoadMode -> Bool isInteractiveMode DoInteractive = True @@ -449,7 +471,6 @@ isCompManagerMode DoInteractive = True isCompManagerMode (DoEval _) = True isCompManagerMode _ = False - -- ----------------------------------------------------------------------------- -- Parsing the mode flag @@ -462,7 +483,7 @@ parseModeFlags args = do runCmdLine (processArgs mode_flags args) (Nothing, [], []) mode = case mModeFlag of - Nothing -> stopBeforeMode StopLn + Nothing -> doMakeMode Just (m, _) -> m errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2 when (not (null errs)) $ ghcError $ errorsToGhcException errs @@ -475,23 +496,16 @@ type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- - Flag "?" (PassFlag (setMode showGhcUsageMode)) - Supported - , Flag "-help" (PassFlag (setMode showGhcUsageMode)) - Supported - , Flag "V" (PassFlag (setMode showVersionMode)) - Supported - , Flag "-version" (PassFlag (setMode showVersionMode)) - Supported - , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) - Supported - , Flag "-info" (PassFlag (setMode showInfoMode)) - Supported - , Flag "-supported-languages" (PassFlag (setMode showSupportedLanguagesMode)) - 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)) - Supported | (k, v) <- compilerInfo, let k' = "-print-" ++ map (replaceSpace . toLower) k replaceSpace ' ' = '-' @@ -503,40 +517,34 @@ mode_flags = ------- interfaces ---------------------------------------------------- [ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f) "--show-iface")) - Supported ------- primary modes ------------------------------------------------ + , Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f + addFlag "-no-link" f)) , Flag "M" (PassFlag (setMode doMkDependHSMode)) - Supported , Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc))) - Supported , Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f addFlag "-fvia-C" f)) - Supported , Flag "S" (PassFlag (setMode (stopBeforeMode As))) - Supported , Flag "-make" (PassFlag (setMode doMakeMode)) - Supported , Flag "-interactive" (PassFlag (setMode doInteractiveMode)) - Supported - , Flag "e" (HasArg (\s -> setMode (doEvalMode s) "-e")) - Supported - - -- -fno-code says to stop after Hsc but don't generate any code. - , Flag "fno-code" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f - addFlag "-fno-code" f - addFlag "-fforce-recomp" f)) - Supported + , Flag "-abi-hash" (PassFlag (setMode doAbiHashMode)) + , Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e")) ] -setMode :: Mode -> String -> ModeM () -setMode newMode newFlag = do +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 && @@ -568,8 +576,8 @@ flagMismatchErr :: String -> String -> String flagMismatchErr oldFlag newFlag = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'" -addFlag :: String -> String -> ModeM () -addFlag s flag = do +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" @@ -578,7 +586,6 @@ addFlag s flag = do -- 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 @@ -588,6 +595,15 @@ doMake srcs = do phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] 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 oneShot hsc_env StopLn srcs >> GHC.printWarnings + else do + o_files <- mapM (\x -> do f <- compileFile hsc_env StopLn x GHC.printWarnings @@ -641,8 +657,8 @@ showInfo dflags = do where flatten (k, String v) = (k, v) flatten (k, FromDynFlags f) = (k, f dflags) -showSupportedLanguages :: IO () -showSupportedLanguages = mapM_ putStrLn supportedLanguages +showSupportedExtensions :: IO () +showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions showVersion :: IO () showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) @@ -701,6 +717,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