X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FMain.hs;h=a91df13575c1f2ce49f56664331a92f05b9cb258;hp=f7c5be72beb722ee6b91d20edfc1cc8cf9c7908b;hb=e0b93c022e39d07b871e9ed97d40617eb6bee63a;hpb=046ee54f048ddd721dcee41916d6a6f68db3b15b diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs index f7c5be7..a91df13 100644 --- a/compiler/main/Main.hs +++ b/compiler/main/Main.hs @@ -1,4 +1,5 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} + ----------------------------------------------------------------------------- -- -- GHC Driver program @@ -13,7 +14,8 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..), +import GHC ( Session, DynFlags(..), HscTarget(..), + GhcMode(..), GhcLink(..), LoadHowMuch(..), dopt, DynFlag(..) ) import CmdLineParser @@ -23,19 +25,20 @@ import HscMain ( newHscEnv ) import DriverPipeline ( oneShot, compileFile ) import DriverMkDepend ( doMkDependHS ) #ifdef GHCI -import InteractiveUI ( ghciWelcomeMsg, interactiveUI ) +import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) #endif -- Various other random stuff that we need -import Config ( cProjectVersion, cBooterVersion, cProjectName ) +import Config +import HscTypes import Packages ( dumpPackages ) import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) -import StaticFlags ( staticFlags, v_Ld_inputs, parseStaticFlags ) -import DynFlags ( defaultDynFlags ) +import StaticFlags +import DynFlags import BasicTypes ( failed ) -import ErrUtils ( putMsg ) -import FastString ( getFastStringTable, isZEncoded, hasZEncoding ) +import ErrUtils +import FastString import Outputable import Util import Panic @@ -43,9 +46,9 @@ import Panic -- Standard Haskell libraries import Control.Exception ( throwDyn ) import System.IO -import System.Directory ( doesDirectoryExist ) import System.Environment import System.Exit +import System.FilePath import Control.Monad import Data.List import Data.Maybe @@ -62,6 +65,7 @@ import Data.Maybe ----------------------------------------------------------------------------- -- GHC's command-line interface +main :: IO () main = GHC.defaultErrorHandler defaultDynFlags $ do @@ -69,38 +73,52 @@ main = argv0 <- getArgs let - (minusB_args, argv1) = partition (prefixMatch "-B") argv0 + (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) - argv2 <- parseStaticFlags argv1 + (argv2, staticFlagWarnings) <- parseStaticFlags argv1 -- 2. Parse the "mode" flags (--make, --interactive etc.) - (cli_mode, argv3) <- parseModeFlags argv2 + (cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 - let mode = case cli_mode of - DoInteractive -> Interactive - DoEval _ -> Interactive - DoMake -> BatchCompile - DoMkDependHS -> MkDepend - _ -> OneShot + -- 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 () -- start our GHC session - session <- GHC.newSession mode mbMinusB + session <- GHC.newSession mbMinusB dflags0 <- GHC.getSessionDynFlags session - -- set the default HscTarget. The HscTarget can be further - -- adjusted on a module by module basis, using only the -fvia-C and - -- -fasm flags. If the default HscTarget is not HscC or HscAsm, - -- -fvia-C and -fasm have no effect. - let lang = case cli_mode of - DoInteractive -> HscInterpreted - DoEval _ -> HscInterpreted - _other -> hscTarget dflags0 - - let dflags1 = dflags0{ ghcMode = mode, - hscTarget = lang, + -- set the default GhcMode, HscTarget and GhcLink. The HscTarget + -- can be further adjusted on a module by module basis, using only + -- the -fvia-C and -fasm flags. If the default HscTarget is not + -- HscC or HscAsm, -fvia-C and -fasm have no effect. + 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) + + 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 @@ -110,23 +128,28 @@ main = -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files - (dflags, fileish_args) <- GHC.parseDynamicFlags dflags1 argv3 + (dflags2, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1 argv3 + + let flagWarnings = staticFlagWarnings + ++ modeFlagWarnings + ++ dynamicFlagWarnings + handleFlagWarnings dflags2 flagWarnings -- make sure we clean up after ourselves - GHC.defaultCleanupHandler dflags $ do + GHC.defaultCleanupHandler dflags2 $ do - -- Display banner - showBanner cli_mode dflags + showBanner cli_mode dflags2 -- we've finished manipulating the DynFlags, update the session - GHC.setSessionDynFlags session dflags - dflags <- GHC.getSessionDynFlags session + GHC.setSessionDynFlags session dflags2 + dflags3 <- GHC.getSessionDynFlags session + hsc_env <- GHC.sessionHscEnv session 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 normalisePath fileish_args + normal_fileish_paths = map normalise fileish_args (srcs, objs) = partition_args normal_fileish_paths [] [] -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on @@ -134,32 +157,36 @@ main = mapM_ (consIORef v_Ld_inputs) (reverse objs) ---------------- Display configuration ----------- - when (verbosity dflags >= 4) $ - dumpPackages dflags + when (verbosity dflags3 >= 4) $ + dumpPackages dflags3 - when (verbosity dflags >= 3) $ do + when (verbosity dflags3 >= 3) $ do hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) ---------------- Final sanity checking ----------- - checkOptions cli_mode dflags srcs objs + checkOptions cli_mode dflags3 srcs objs - ---------------- Do the business ----------- + ---------------- Do the business ----------- + let alreadyHandled = panic (show cli_mode ++ + " should already have been handled") case cli_mode of - ShowUsage -> showGhcUsage dflags cli_mode - PrintLibdir -> putStrLn (topDir dflags) - ShowVersion -> showVersion - ShowNumVersion -> putStrLn cProjectVersion - ShowInterface f -> doShowIface dflags f - DoMake -> doMake session srcs - DoMkDependHS -> doMkDependHS session (map fst srcs) - StopBefore p -> oneShot dflags p srcs - DoInteractive -> interactiveUI session srcs Nothing - DoEval expr -> interactiveUI session srcs (Just expr) - - dumpFinalStats dflags + 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 #ifndef GHCI +interactiveUI :: a -> b -> c -> IO () interactiveUI _ _ _ = throwDyn (CmdLineError "not built for interactive use") #endif @@ -169,6 +196,8 @@ interactiveUI _ _ _ = -- interpret the -x option, and attach a (Maybe Phase) to each source -- file indicating the phase specified by the -x option in force, if any. +partition_args :: [String] -> [(String, Maybe Phase)] -> [String] + -> ([(String, Maybe Phase)], [String]) partition_args [] srcs objs = (reverse srcs, reverse objs) partition_args ("-x":suff:args) srcs objs | "none" <- suff = partition_args args srcs objs @@ -198,6 +227,7 @@ partition_args (arg:args) srcs objs Everything else is considered to be a linker object, and passed straight through to the linker. -} +looks_like_an_input :: String -> Bool looks_like_an_input m = isSourceFilename m || looksLikeModuleName m || '.' `notElem` m @@ -212,10 +242,15 @@ checkOptions cli_mode dflags srcs objs = do let unknown_opts = [ f | (f@('-':_), _) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) + when (notNull (filter isRTSWay (wayNames dflags)) + && isInterpretiveMode cli_mode) $ + putStrLn ("Warning: -debug, -threaded and -ticky are ignored by GHCi") + -- -prof and --interactive are not a good combination - when (notNull (wayNames dflags) && isInterpretiveMode cli_mode) $ + when (notNull (filter (not . isRTSWay) (wayNames dflags)) + && isInterpretiveMode cli_mode) $ do throwDyn (UsageError - "--interactive can't be used with -prof, -ticky, -unreg or -smp.") + "--interactive can't be used with -prof or -unreg.") -- -ohi sanity check if (isJust (outputHi dflags) && (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) @@ -249,11 +284,7 @@ checkOptions cli_mode dflags srcs objs = do -- verifyOutputFiles :: DynFlags -> IO () verifyOutputFiles dflags = do - let odir = objectDir dflags - when (isJust odir) $ do - let dir = fromJust odir - flg <- doesDirectoryExist dir - when (not flg) (nonExistentDir "-odir" dir) + -- not -odir: we create the directory for -odir if it doesn't exist (#2278). let ofile = outputFile dflags when (isJust ofile) $ do let fn = fromJust ofile @@ -274,30 +305,34 @@ verifyOutputFiles dflags = do -- GHC modes of operation data CmdLineMode - = ShowUsage -- ghc -? - | PrintLibdir -- ghc --print-libdir - | ShowVersion -- ghc -V/--version - | ShowNumVersion -- ghc --numeric-version - | ShowInterface String -- ghc --show-iface - | DoMkDependHS -- ghc -M - | StopBefore Phase -- ghc -E | -C | -S - -- StopBefore StopLn is the default - | DoMake -- ghc --make - | DoInteractive -- ghc --interactive - | DoEval String -- ghc -e + = ShowUsage -- ghc -? + | PrintLibdir -- ghc --print-libdir + | ShowInfo -- ghc --info + | ShowSupportedLanguages -- ghc --supported-languages + | ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowInterface String -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoInteractive -- ghc --interactive + | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"] deriving (Show) -isInteractiveMode, isInterpretiveMode :: CmdLineMode -> Bool -isLinkMode, isCompManagerMode :: CmdLineMode -> Bool - +#ifdef GHCI +isInteractiveMode :: CmdLineMode -> Bool isInteractiveMode DoInteractive = True isInteractiveMode _ = False +#endif -- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode :: CmdLineMode -> Bool isInterpretiveMode DoInteractive = True isInterpretiveMode (DoEval _) = True isInterpretiveMode _ = False +needsInputsMode :: CmdLineMode -> Bool needsInputsMode DoMkDependHS = True needsInputsMode (StopBefore _) = True needsInputsMode DoMake = True @@ -305,10 +340,12 @@ needsInputsMode _ = False -- True if we are going to attempt to link in this mode. -- (we might not actually link, depending on the GhcLink flag) +isLinkMode :: CmdLineMode -> Bool isLinkMode (StopBefore StopLn) = True isLinkMode DoMake = True isLinkMode _ = False +isCompManagerMode :: CmdLineMode -> Bool isCompManagerMode DoMake = True isCompManagerMode DoInteractive = True isCompManagerMode (DoEval _) = True @@ -318,77 +355,103 @@ isCompManagerMode _ = False -- ----------------------------------------------------------------------------- -- Parsing the mode flag -parseModeFlags :: [String] -> IO (CmdLineMode, [String]) +parseModeFlags :: [String] -> IO (CmdLineMode, [String], [String]) parseModeFlags args = do - let ((leftover, errs), (mode, _, flags)) = + 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) + return (mode, flags' ++ leftover, warns) -type ModeM a = CmdLineP (CmdLineMode, String, [String]) a +type ModeM = CmdLineP (CmdLineMode, String, [String]) -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) -- so we collect the new ones and return them. -mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))] +mode_flags :: [Flag ModeM] mode_flags = [ ------- help / version ---------------------------------------------- - ( "?" , PassFlag (setMode ShowUsage)) - , ( "-help" , PassFlag (setMode ShowUsage)) - , ( "-print-libdir" , PassFlag (setMode PrintLibdir)) - , ( "V" , PassFlag (setMode ShowVersion)) - , ( "-version" , PassFlag (setMode ShowVersion)) - , ( "-numeric-version", PassFlag (setMode ShowNumVersion)) + Flag "?" (PassFlag (setMode ShowUsage)) + Supported + , Flag "-help" (PassFlag (setMode ShowUsage)) + Supported + , Flag "-print-libdir" (PassFlag (setMode PrintLibdir)) + Supported + , Flag "V" (PassFlag (setMode ShowVersion)) + Supported + , Flag "-version" (PassFlag (setMode ShowVersion)) + Supported + , Flag "-numeric-version" (PassFlag (setMode ShowNumVersion)) + Supported + , Flag "-info" (PassFlag (setMode ShowInfo)) + Supported + , Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages)) + Supported ------- interfaces ---------------------------------------------------- - , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f) - "--show-iface")) + , Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f) + "--show-iface")) + Supported ------- primary modes ------------------------------------------------ - , ( "M" , PassFlag (setMode DoMkDependHS)) - , ( "E" , PassFlag (setMode (StopBefore anyHsc))) - , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fvia-C")) - , ( "S" , PassFlag (setMode (StopBefore As))) - , ( "-make" , PassFlag (setMode DoMake)) - , ( "-interactive" , PassFlag (setMode DoInteractive)) - , ( "e" , HasArg (\s -> setMode (DoEval s) "-e")) - - -- -fno-code says to stop after Hsc but don't generate any code. - , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fno-code" - addFlag "-no-recomp")) + , Flag "M" (PassFlag (setMode DoMkDependHS)) + Supported + , Flag "E" (PassFlag (setMode (StopBefore anyHsc))) + Supported + , Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fvia-C")) + Supported + , Flag "S" (PassFlag (setMode (StopBefore As))) + Supported + , Flag "-make" (PassFlag (setMode DoMake)) + Supported + , Flag "-interactive" (PassFlag (setMode DoInteractive)) + Supported + , Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e")) + Supported + + -- -fno-code says to stop after Hsc but don't generate any code. + , Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fno-code" + addFlag "-fforce-recomp")) + Supported ] setMode :: CmdLineMode -> String -> ModeM () -setMode m flag = do - (old_mode, old_flag, flags) <- getCmdLineState - when (notNull old_flag && flag /= old_flag) $ - throwDyn (UsageError - ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) - putCmdLineState (m, flag, flags) +setMode m flag = updateMode (\_ -> m) flag + +updateDoEval :: String -> CmdLineMode -> CmdLineMode +updateDoEval expr (DoEval exprs) = DoEval (expr : exprs) +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 + ("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) + (m, f, flags') <- getCmdLineState + putCmdLineState (m, f, s:flags') -- ---------------------------------------------------------------------------- -- Run --make mode doMake :: Session -> [(String,Maybe Phase)] -> IO () -doMake sess [] = throwDyn (UsageError "no input files") +doMake _ [] = throwDyn (UsageError "no input files") doMake sess srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f - haskellish (f,Just phase) = + haskellish (_,Just phase) = phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] - dflags <- GHC.getSessionDynFlags sess - o_files <- mapM (compileFile dflags StopLn) non_hs_srcs + hsc_env <- GHC.sessionHscEnv sess + o_files <- mapM (compileFile hsc_env StopLn) non_hs_srcs mapM_ (consIORef v_Ld_inputs) (reverse o_files) targets <- mapM (uncurry GHC.guessTarget) hs_srcs @@ -410,35 +473,45 @@ doShowIface dflags file = do -- Various banners and verbosity output. showBanner :: CmdLineMode -> DynFlags -> IO () -showBanner cli_mode dflags = do +showBanner _cli_mode dflags = do let verb = verbosity dflags - -- Show the GHCi banner -# ifdef GHCI - when (isInteractiveMode cli_mode && verb >= 1) $ - hPutStrLn stdout ghciWelcomeMsg -# endif - - -- Display details of the configuration in verbose mode - when (not (isInteractiveMode cli_mode) && verb >= 2) $ - do hPutStr stderr "Glasgow Haskell Compiler, Version " - hPutStr stderr cProjectVersion - hPutStr stderr ", for Haskell 98, compiled by GHC version " + #ifdef GHCI - -- GHCI is only set when we are bootstrapping... - hPutStrLn stderr cProjectVersion -#else - hPutStrLn stderr cBooterVersion + -- Show the GHCi banner + when (isInteractiveMode _cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg #endif + -- Display details of the configuration in verbose mode + when (verb >= 2) $ + do hPutStr stderr "Glasgow Haskell Compiler, Version " + hPutStr stderr cProjectVersion + hPutStr stderr ", for Haskell 98, stage " + hPutStr stderr cStage + hPutStr stderr " booted by GHC version " + hPutStrLn stderr cBooterVersion + +-- We print out a Read-friendly string, but a prettier one than the +-- Show instance gives us +showInfo :: IO () +showInfo = do + let sq x = " [" ++ x ++ "\n ]" + putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo + exitWith ExitSuccess + +showSupportedLanguages :: IO () +showSupportedLanguages = do mapM_ putStrLn supportedLanguages + exitWith ExitSuccess + showVersion :: IO () showVersion = do putStrLn (cProjectName ++ ", version " ++ cProjectVersion) exitWith ExitSuccess +showGhcUsage :: DynFlags -> CmdLineMode -> IO () showGhcUsage dflags cli_mode = do let usage_path - | DoInteractive <- cli_mode = ghcUsagePath dflags - | otherwise = ghciUsagePath dflags + | DoInteractive <- cli_mode = ghciUsagePath dflags + | otherwise = ghcUsagePath dflags usage <- readFile usage_path dump usage exitWith ExitSuccess @@ -470,7 +543,8 @@ dumpFastStringStats dflags = do putMsg dflags msg where x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' - + +countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int) countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) countFS entries longest is_z has_z (b:bs) = let