X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FMain.hs;h=df90857fbbb457805cd15d4849a7aa9a0e011b53;hb=59fa6266f00b6edcfc20c491c8de9a1b215dfa22;hp=a91df13575c1f2ce49f56664331a92f05b9cb258;hpb=9412e62942ebab0599c7fb0b358a9d4869647b67;p=ghc-hetmet.git diff --git a/ghc/Main.hs b/ghc/Main.hs index a91df13..df90857 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -14,9 +14,10 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC ( Session, DynFlags(..), HscTarget(..), +import GHC ( DynFlags(..), HscTarget(..), GhcMode(..), GhcLink(..), - LoadHowMuch(..), dopt, DynFlag(..) ) + LoadHowMuch(..), dopt, DynFlag(..), + defaultCallbacks ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) @@ -34,17 +35,19 @@ 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 ) -- Standard Haskell libraries -import Control.Exception ( throwDyn ) import System.IO import System.Environment import System.Exit @@ -67,8 +70,8 @@ import Data.Maybe main :: IO () main = - GHC.defaultErrorHandler defaultDynFlags $ do + GHC.defaultErrorHandler defaultDynFlags $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -77,31 +80,37 @@ main = mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) - (argv2, staticFlagWarnings) <- parseStaticFlags argv1 + let argv1' = map (mkGeneralLocated "on the commandline") argv1 + (argv2, staticFlagWarnings) <- parseStaticFlags argv1' -- 2. Parse the "mode" flags (--make, --interactive etc.) - (cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + (m_uber_mode, 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 () + case m_uber_mode of + -- ShowUsage currently has to be handled specially, as it needs to + -- actually start up GHC so that it can find the usage.txt files + -- in the libdir. It would be nice to embed the text in the + -- executable so that we don't have to do that, and things are more + -- uniform here. + Just ShowUsage -> return () + Just um -> + do case um of + ShowInfo -> showInfo + ShowSupportedLanguages -> showSupportedLanguages + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + exitWith ExitSuccess + Nothing -> return () -- start our GHC session - session <- GHC.newSession mbMinusB + GHC.runGhc mbMinusB $ do - dflags0 <- GHC.getSessionDynFlags session + dflags0 <- GHC.getSessionDynFlags -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only @@ -110,85 +119,98 @@ main = 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) + DoInteractive -> (CompManager, HscInterpreted, LinkInMemory) + DoEval _ -> (CompManager, HscInterpreted, LinkInMemory) + DoMake -> (CompManager, dflt_target, LinkBinary) + DoMkDependHS -> (MkDepend, dflt_target, LinkBinary) + _ -> (OneShot, dflt_target, LinkBinary) let dflags1 = dflags0{ ghcMode = mode, 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 + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + verbosity = case cli_mode 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 <- cli_mode = imp_qual_enabled + | DoEval _ <- cli_mode = 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 argv3 + + -- As noted earlier, currently we hvae to handle ShowUsage down here + case m_uber_mode of + Just ShowUsage -> liftIO $ showGhcUsage dflags2 cli_mode + _ -> return () let flagWarnings = staticFlagWarnings ++ modeFlagWarnings ++ dynamicFlagWarnings - handleFlagWarnings dflags2 flagWarnings - -- make sure we clean up after ourselves + handleSourceError (\e -> do + GHC.printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ + handleFlagWarnings dflags2 flagWarnings + + -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags2 $ do - showBanner cli_mode dflags2 + liftIO $ showBanner cli_mode 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 cli_mode 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.printExceptionAndWarnings e + liftIO $ exitWith (ExitFailure 1)) $ do + case cli_mode of + PrintLibdir -> liftIO $ putStrLn (topDir dflags3) + ShowInterface f -> liftIO $ doShowIface dflags3 f + DoMake -> doMake srcs + DoMkDependHS -> doMkDependHS (map fst srcs) + StopBefore p -> oneShot hsc_env p srcs >> GHC.printWarnings + DoInteractive -> interactiveUI srcs Nothing + DoEval exprs -> interactiveUI srcs $ Just $ reverse exprs + + liftIO $ dumpFinalStats dflags3 + liftIO $ exitWith ExitSuccess #ifndef GHCI -interactiveUI :: a -> b -> c -> IO () -interactiveUI _ _ _ = - throwDyn (CmdLineError "not built for interactive use") +interactiveUI :: b -> c -> Ghc () +interactiveUI _ _ = + ghcError (CmdLineError "not built for interactive use") #endif -- ----------------------------------------------------------------------------- @@ -235,6 +257,9 @@ looks_like_an_input m = isSourceFilename m -- ----------------------------------------------------------------------------- -- Option sanity checks +-- | Ensure sanity of options. +-- +-- Throws 'UsageError' or 'CmdLineError' if not. checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). checkOptions cli_mode dflags srcs objs = do @@ -244,29 +269,34 @@ checkOptions cli_mode dflags srcs objs = do when (notNull (filter isRTSWay (wayNames dflags)) && isInterpretiveMode cli_mode) $ - putStrLn ("Warning: -debug, -threaded and -ticky are ignored by GHCi") + 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) $ - do throwDyn (UsageError + 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)) - then throwDyn (UsageError "-ohi can only be used when compiling a single source file") + 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)) - then throwDyn (UsageError "can't apply -o to multiple source files") + then ghcError (UsageError "can't apply -o to multiple source files") else do + let not_linking = not (isLinkMode cli_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 - then throwDyn (UsageError "no input files") + if null srcs && (null objs || not_linking) && needsInputsMode cli_mode + then ghcError (UsageError "no input files") else do -- Verify that output files point somewhere sensible. @@ -297,20 +327,23 @@ verifyOutputFiles dflags = do when (not flg) (nonExistentDir "-ohi" hi) where nonExistentDir flg dir = - throwDyn (CmdLineError ("error: directory portion of " ++ + ghcError (CmdLineError ("error: directory portion of " ++ show dir ++ " does not exist (used with " ++ show flg ++ " option.)")) ----------------------------------------------------------------------------- -- GHC modes of operation -data CmdLineMode +data UberMode = ShowUsage -- ghc -? - | PrintLibdir -- ghc --print-libdir - | ShowInfo -- ghc --info - | ShowSupportedLanguages -- ghc --supported-languages | ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version + | ShowSupportedLanguages -- ghc --supported-languages + | ShowInfo -- ghc --info + deriving (Show) + +data CmdLineMode + = PrintLibdir -- ghc --print-libdir | ShowInterface String -- ghc --show-iface | DoMkDependHS -- ghc -M | StopBefore Phase -- ghc -E | -C | -S @@ -343,6 +376,8 @@ needsInputsMode _ = False isLinkMode :: CmdLineMode -> Bool isLinkMode (StopBefore StopLn) = True isLinkMode DoMake = True +isLinkMode DoInteractive = True +isLinkMode (DoEval _) = True isLinkMode _ = False isCompManagerMode :: CmdLineMode -> Bool @@ -355,36 +390,40 @@ isCompManagerMode _ = False -- ----------------------------------------------------------------------------- -- Parsing the mode flag -parseModeFlags :: [String] -> IO (CmdLineMode, [String], [String]) +parseModeFlags :: [Located String] + -> IO (Maybe UberMode, + CmdLineMode, + [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 - throwDyn (UsageError (unlines errs)) - return (mode, flags' ++ leftover, warns) + let ((leftover, errs, warns), (mUberMode, mode, _, flags')) = + runCmdLine (processArgs mode_flags args) + (Nothing, StopBefore StopLn, "", []) + when (not (null errs)) $ ghcError $ errorsToGhcException errs + return (mUberMode, mode, flags' ++ leftover, warns) -type ModeM = CmdLineP (CmdLineMode, String, [String]) +type ModeM = CmdLineP (Maybe UberMode, CmdLineMode, 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)) + Flag "?" (NoArg (setUberMode ShowUsage)) Supported - , Flag "-help" (PassFlag (setMode ShowUsage)) + , Flag "-help" (NoArg (setUberMode ShowUsage)) Supported - , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) + , Flag "V" (NoArg (setUberMode ShowVersion)) Supported - , Flag "V" (PassFlag (setMode ShowVersion)) + , Flag "-version" (NoArg (setUberMode ShowVersion)) Supported - , Flag "-version" (PassFlag (setMode ShowVersion)) + , Flag "-numeric-version" (NoArg (setUberMode ShowNumVersion)) Supported - , Flag "-numeric-version" (PassFlag (setMode ShowNumVersion)) + , Flag "-info" (NoArg (setUberMode ShowInfo)) Supported - , Flag "-info" (PassFlag (setMode ShowInfo)) + , Flag "-supported-languages" (NoArg (setUberMode ShowSupportedLanguages)) Supported - , Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages)) + , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) Supported ------- interfaces ---------------------------------------------------- @@ -416,6 +455,11 @@ mode_flags = Supported ] +setUberMode :: UberMode -> ModeM () +setUberMode m = do + (_, cmdLineMode, flag, flags') <- getCmdLineState + putCmdLineState (Just m, cmdLineMode, flag, flags') + setMode :: CmdLineMode -> String -> ModeM () setMode m flag = updateMode (\_ -> m) flag @@ -425,24 +469,25 @@ 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 throwDyn (UsageError + (m_uber_mode, old_mode, old_flag, flags') <- getCmdLineState + if null old_flag || flag == old_flag + then putCmdLineState (m_uber_mode, f old_mode, flag, flags') + else 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') + (u, m, f, flags') <- getCmdLineState + -- XXX Can we get a useful Loc? + putCmdLineState (u, m, f, mkGeneralLocated "addFlag" s : flags') -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: Session -> [(String,Maybe Phase)] -> IO () -doMake _ [] = throwDyn (UsageError "no input files") -doMake sess srcs = do +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) = @@ -450,14 +495,19 @@ 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 + o_files <- mapM (\x -> do + f <- compileFile hsc_env StopLn x + GHC.printWarnings + return f) + 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 () @@ -466,7 +516,7 @@ doMake sess srcs = do doShowIface :: DynFlags -> FilePath -> IO () doShowIface dflags file = do - hsc_env <- newHscEnv dflags + hsc_env <- newHscEnv defaultCallbacks dflags showIface hsc_env file -- --------------------------------------------------------------------------- @@ -560,4 +610,4 @@ countFS entries longest is_z has_z (b:bs) = -- Util unknownFlagsErr :: [String] -> a -unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs)) +unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))