X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FMain.hs;h=9c993345bb7fa093f2722e668466f637359a298d;hb=fdf8656855d26105ff36bdd24d41827b05037b91;hp=5a2ebc9e4c12fc1fdd3aeb0a834209a4c6ef2622;hpb=5a57316c7faf6628a0d999a3a8dc68f09a158487;p=ghc-hetmet.git diff --git a/ghc/Main.hs b/ghc/Main.hs index 5a2ebc9..9c99334 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,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 @@ -104,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 @@ -166,9 +167,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,13 +204,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 -> 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 @@ -349,13 +350,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) @@ -428,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 @@ -461,7 +470,6 @@ isCompManagerMode DoInteractive = True isCompManagerMode (DoEval _) = True isCompManagerMode _ = False - -- ----------------------------------------------------------------------------- -- Parsing the mode flag @@ -474,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 @@ -487,23 +495,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 ' ' = '-' @@ -515,42 +516,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 "-abi-hash" (PassFlag (setMode doAbiHashMode)) - 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 "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 && @@ -582,8 +575,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" @@ -592,20 +585,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) @@ -622,7 +620,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 -- --------------------------------------------------------------------------- @@ -641,7 +639,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 @@ -655,8 +653,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)