import qualified GHC
import GHC ( -- DynFlags(..), HscTarget(..),
-- GhcMode(..), GhcLink(..),
- LoadHowMuch(..), -- dopt, DynFlag(..),
- defaultCallbacks )
+ Ghc, GhcMonad(..),
+ LoadHowMuch(..) )
import CmdLineParser
-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
import InteractiveUI ( interactiveUI, ghciWelcomeMsg )
#endif
+
-- Various other random stuff that we need
import Config
import HscTypes
import SrcLoc
import Util
import Panic
--- import MonadUtils ( liftIO )
+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
-- 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
case mode of
Left preStartupMode ->
do case preStartupMode of
- ShowSupportedLanguages -> showSupportedLanguages
+ ShowSupportedExtensions -> showSupportedExtensions
ShowVersion -> showVersion
ShowNumVersion -> putStrLn cProjectVersion
Print str -> putStrLn str
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,
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
---------------- Do the business -----------
handleSourceError (\e -> do
- GHC.printExceptionAndWarnings e
+ 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 -> 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
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)
| 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)
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
isCompManagerMode (DoEval _) = True
isCompManagerMode _ = False
-
-- -----------------------------------------------------------------------------
-- Parsing the mode flag
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
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 ' ' = '-'
------- 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 &&
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"
-- 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
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)
doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
- hsc_env <- newHscEnv defaultCallbacks dflags
+ hsc_env <- newHscEnv dflags
showIface hsc_env file
-- ---------------------------------------------------------------------------
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
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)
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
projects / ghc-hetmet.git / blobdiff