X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FMain.hs;h=12d8dd202b4bbe07f139bec9881e7f3ac177950a;hp=8348897bd3f83752160bbba3103e7d178cbe169a;hb=5cd39aa33f970ff42e22b1c9c73502e4229dc488;hpb=218c7fe5cce74b8e8c3ef290d348e6576a0045fb diff --git a/ghc/Main.hs b/ghc/Main.hs index 8348897..12d8dd2 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -14,8 +14,8 @@ module Main (main) where 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.) @@ -44,7 +44,7 @@ import Outputable import SrcLoc import Util import Panic --- import MonadUtils ( liftIO ) +import MonadUtils ( liftIO ) -- Imports for --abi-hash import LoadIface ( loadUserInterface ) @@ -76,8 +76,10 @@ import Data.Maybe -- GHC's command-line interface main :: IO () -main = - GHC.defaultErrorHandler defaultDynFlags $ do +main = do + hSetBuffering stdout NoBuffering + let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings") + GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -104,7 +106,7 @@ main = case mode of Left preStartupMode -> do case preStartupMode of - ShowSupportedLanguages -> showSupportedLanguages + ShowSupportedExtensions -> showSupportedExtensions ShowVersion -> showVersion ShowNumVersion -> putStrLn cProjectVersion Print str -> putStrLn str @@ -166,9 +168,9 @@ main' postLoadMode dflags0 args flagWarnings = do 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 @@ -203,14 +205,13 @@ main' postLoadMode dflags0 args flagWarnings = 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 -> do doMkDependHS (map fst srcs) - GHC.printWarnings - StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + 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 @@ -350,16 +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 - -printMode :: String -> Mode -printMode str = mkPreStartupMode (Print str) +showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode +showVersionMode = mkPreStartupMode ShowVersion +showNumVersionMode = mkPreStartupMode ShowNumVersion +showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left @@ -383,8 +381,10 @@ showGhcUsageMode = mkPreLoadMode ShowGhcUsage showGhciUsageMode = mkPreLoadMode ShowGhciUsage showInfoMode = mkPreLoadMode ShowInfo -printWithDynFlagsMode :: (DynFlags -> String) -> Mode -printWithDynFlagsMode f = mkPreLoadMode (PrintWithDynFlags f) +printSetting :: String -> Mode +printSetting k = mkPreLoadMode (PrintWithDynFlags f) + where f dflags = fromMaybe (panic ("Setting not found: " ++ show k)) + $ lookup k (compilerInfo dflags) mkPreLoadMode :: PreLoadMode -> Mode mkPreLoadMode = Right . Left @@ -429,6 +429,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 @@ -462,7 +470,6 @@ isCompManagerMode DoInteractive = True isCompManagerMode (DoEval _) = True isCompManagerMode _ = False - -- ----------------------------------------------------------------------------- -- Parsing the mode flag @@ -475,7 +482,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 @@ -488,70 +495,71 @@ 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, + [ Flag k' (PassFlag (setMode (printSetting k))) + | k <- ["Project version", + "Booter version", + "Stage", + "Build platform", + "Host platform", + "Target platform", + "Have interpreter", + "Object splitting supported", + "Have native code generator", + "Support SMP", + "Unregisterised", + "Tables next to code", + "RTS ways", + "Leading underscore", + "Debug on", + "LibDir", + "Global Package DB", + "C compiler flags", + "Gcc Linker flags", + "Ld Linker flags"], 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 (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 "-abi-hash" (PassFlag (setMode doAbiHashMode)) - Supported , Flag "e" (SepArg (\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 ] -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 && @@ -583,8 +591,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" @@ -593,20 +601,25 @@ 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 haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = - phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] + phase `notElem` [As, Cc, Cobjc, 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) @@ -623,7 +636,7 @@ doMake srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv defaultCallbacks dflags + hsc_env <- newHscEnv dflags showIface hsc_env file -- --------------------------------------------------------------------------- @@ -642,7 +655,7 @@ showBanner _postLoadMode dflags = do 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 @@ -652,12 +665,10 @@ showBanner _postLoadMode dflags = do 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) + putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags -showSupportedLanguages :: IO () -showSupportedLanguages = mapM_ putStrLn supportedLanguages +showSupportedExtensions :: IO () +showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions showVersion :: IO () showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)