X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FMain.hs;h=c80ca78a8084cd36e21da7c68b1097098cbe00bd;hb=704bbd5482ed6781bc436d1a28d558713dd13c59;hp=a9747168360f686bce2e323cf5c6e9dddc1e2918;hpb=fb9d3922c8ccc9b3f7138a821ffb635e6c65b149;p=ghc-hetmet.git diff --git a/ghc/Main.hs b/ghc/Main.hs index a974716..c80ca78 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -14,7 +14,7 @@ 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(..) ) import CmdLineParser @@ -34,15 +34,17 @@ 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 System.IO @@ -67,8 +69,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,7 +79,8 @@ 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 @@ -99,9 +102,9 @@ main = _ -> 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,21 +113,21 @@ 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 - } + -- 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 @@ -133,68 +136,72 @@ main = | otherwise = dflags1 where imp_qual_enabled = dflags1 `dopt_set` Opt_ImplicitImportQualified - -- The rest of the arguments are "dynamic" - -- Leftover ones are presumably files + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1a argv3 let flagWarnings = staticFlagWarnings ++ modeFlagWarnings ++ dynamicFlagWarnings - handleFlagWarnings dflags2 flagWarnings + liftIO $ handleFlagWarnings dflags2 flagWarnings - -- make sure we clean up after ourselves + -- 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)) $ + case cli_mode of + ShowUsage -> liftIO $ showGhcUsage dflags3 cli_mode + PrintLibdir -> liftIO $ putStrLn (topDir dflags3) + ShowSupportedLanguages -> alreadyHandled + ShowVersion -> alreadyHandled + ShowNumVersion -> alreadyHandled + 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 _ _ _ = +interactiveUI :: b -> c -> Ghc () +interactiveUI _ _ = ghcError (CmdLineError "not built for interactive use") #endif @@ -242,6 +249,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 @@ -362,15 +372,15 @@ isCompManagerMode _ = False -- ----------------------------------------------------------------------------- -- Parsing the mode flag -parseModeFlags :: [String] -> IO (CmdLineMode, [String], [String]) +parseModeFlags :: [Located String] + -> IO (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 - ghcError (UsageError (unlines errs)) + when (not (null errs)) $ ghcError $ errorsToGhcException errs return (mode, flags' ++ leftover, warns) -type ModeM = CmdLineP (CmdLineMode, String, [String]) +type ModeM = CmdLineP (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. @@ -441,15 +451,16 @@ updateMode f flag = do addFlag :: String -> ModeM () addFlag s = do (m, f, flags') <- getCmdLineState - putCmdLineState (m, f, s:flags') + -- XXX Can we get a useful Loc? + putCmdLineState (m, f, mkGeneralLocated "addFlag" s : flags') -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: Session -> [(String,Maybe Phase)] -> IO () -doMake _ [] = ghcError (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) = @@ -457,14 +468,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 ()