X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMain.hs;h=468c0a632c8854a8e24a3d9910a829b642b52fb6;hb=4a3042fcc68554ef59966430d2c6f1b70470d222;hp=ad25d559f37223303631d5b682439b970873288a;hpb=069370a53a92a68a6df163f07cec47b3d62632e7;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index ad25d55..468c0a6 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -13,12 +13,13 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..) ) +import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..), + LoadHowMuch(..), dopt, DynFlag(..) ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) import MkIface ( showIface ) -import DriverPipeline ( oneShot ) +import DriverPipeline ( oneShot, compileFile ) import DriverMkDepend ( doMkDependHS ) import SysTools ( getTopDir, getUsageMsgPaths ) #ifdef GHCI @@ -28,16 +29,21 @@ import InteractiveUI ( ghciWelcomeMsg, interactiveUI ) -- Various other random stuff that we need import Config ( cProjectVersion, cBooterVersion, cProjectName ) import Packages ( dumpPackages, initPackages ) -import DriverPhases ( Phase(..), isSourceFilename, anyHsc ) -import StaticFlags ( staticFlags, v_Ld_inputs ) +import DriverPhases ( Phase(..), isSourceFilename, anyHsc, + startPhase, isHaskellSrcFilename ) +import StaticFlags ( staticFlags, v_Ld_inputs, parseStaticFlags ) +import DynFlags ( defaultDynFlags ) import BasicTypes ( failed ) +import ErrUtils ( Message, debugTraceMsg, putMsg ) +import FastString ( getFastStringTable, isZEncoded, hasZEncoding ) +import Outputable import Util import Panic -- Standard Haskell libraries import EXCEPTION ( throwDyn ) import IO -import Directory ( doesFileExist, doesDirectoryExist ) +import Directory ( doesDirectoryExist ) import System ( getArgs, exitWith, ExitCode(..) ) import Monad import List @@ -56,10 +62,10 @@ import Maybe -- GHC's command-line interface main = - GHC.defaultErrorHandler $ do + GHC.defaultErrorHandler defaultDynFlags $ do argv0 <- getArgs - argv1 <- GHC.init argv0 + argv1 <- parseStaticFlags =<< GHC.initFromArgs argv0 -- 2. Parse the "mode" flags (--make, --interactive etc.) (cli_mode, argv2) <- parseModeFlags argv1 @@ -112,32 +118,11 @@ main = GHC.setSessionDynFlags session dflags let - {- - We split out the object files (.o, .dll) and add them - to v_Ld_inputs for use by the linker. - - The following things should be considered compilation manager inputs: - - - haskell source files (strings ending in .hs, .lhs or other - haskellish extension), - - - module names (not forgetting hierarchical module names), - - - and finally we consider everything not containing a '.' to be - a comp manager input, as shorthand for a .hs or .lhs filename. - - Everything else is considered to be a linker object, and passed - straight through to the linker. - -} - looks_like_an_input m = isSourceFilename m - || looksLikeModuleName m - || '.' `notElem` m - -- 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 - (srcs, objs) = partition looks_like_an_input normal_fileish_paths + (srcs, objs) = partition_args normal_fileish_paths [] [] -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on -- the command-line. @@ -161,11 +146,18 @@ main = ShowNumVersion -> putStrLn cProjectVersion ShowInterface f -> showIface f DoMake -> doMake session srcs - DoMkDependHS -> doMkDependHS session srcs - StopBefore p -> oneShot dflags p srcs + DoMkDependHS -> doMkDependHS session (map fst srcs) + StopBefore p + -- Stop after compiling Haskell if we aren't + -- interested in any further results. + | HscNothing <- hscTarget dflags + -> oneShot dflags HCc srcs + | otherwise + -> oneShot dflags p srcs DoInteractive -> interactiveUI session srcs Nothing DoEval expr -> interactiveUI session srcs (Just expr) + dumpFinalStats dflags exitWith ExitSuccess #ifndef GHCI @@ -173,15 +165,52 @@ interactiveUI _ _ _ = throwDyn (CmdLineError "not built for interactive use") #endif +-- ----------------------------------------------------------------------------- +-- Splitting arguments into source files and object files. This is where we +-- 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 [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to v_Ld_inputs for use by the linker. + + The following things should be considered compilation manager inputs: + + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + + - module names (not forgetting hierarchical module names), + + - and finally we consider everything not containing a '.' to be + a comp manager input, as shorthand for a .hs or .lhs filename. + + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m + || '.' `notElem` m -- ----------------------------------------------------------------------------- -- Option sanity checks -checkOptions :: CmdLineMode -> DynFlags -> [String] -> [String] -> IO () +checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). checkOptions cli_mode dflags srcs objs = do -- Complain about any unknown flags - let unknown_opts = [ f | f@('-':_) <- srcs ] + let unknown_opts = [ f | (f@('-':_), _) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) -- -prof and --interactive are not a good combination @@ -221,7 +250,7 @@ checkOptions cli_mode dflags srcs objs = do -- verifyOutputFiles :: DynFlags -> IO () verifyOutputFiles dflags = do - let odir = outputDir dflags + let odir = objectDir dflags when (isJust odir) $ do let dir = fromJust odir flg <- doesDirectoryExist dir @@ -325,11 +354,6 @@ mode_flags = , ( "-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")) ] setMode :: CmdLineMode -> String -> ModeM () @@ -349,12 +373,23 @@ addFlag s = do -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: Session -> [String] -> IO () +doMake :: Session -> [(String,Maybe Phase)] -> IO () doMake sess [] = throwDyn (UsageError "no input files") doMake sess srcs = do - targets <- mapM GHC.guessTarget srcs + let (hs_srcs, non_hs_srcs) = partition haskellish srcs + + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + haskellish (f,Just phase) = + phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] + + dflags <- GHC.getSessionDynFlags sess + o_files <- mapM (compileFile dflags StopLn) non_hs_srcs + mapM_ (consIORef v_Ld_inputs) (reverse o_files) + + targets <- mapM (uncurry GHC.guessTarget) hs_srcs GHC.setTargets sess targets - ok_flag <- GHC.load sess Nothing + ok_flag <- GHC.load sess LoadAllTargets when (failed ok_flag) (exitWith (ExitFailure 1)) return () @@ -375,7 +410,12 @@ showBanner cli_mode dflags = do 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 +#endif showVersion :: IO () showVersion = do @@ -392,8 +432,43 @@ showGhcUsage cli_mode = do exitWith ExitSuccess where dump "" = return () - dump ('$':'$':s) = hPutStr stderr progName >> dump s - dump (c:s) = hPutChar stderr c >> dump s + dump ('$':'$':s) = putStr progName >> dump s + dump (c:s) = putChar c >> dump s + +dumpFinalStats :: DynFlags -> IO () +dumpFinalStats dflags = + when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags + +dumpFastStringStats :: DynFlags -> IO () +dumpFastStringStats dflags = do + buckets <- getFastStringTable + let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets + msg = text "FastString stats:" $$ + nest 4 (vcat [text "size: " <+> int (length buckets), + text "entries: " <+> int entries, + text "longest chain: " <+> int longest, + text "z-encoded: " <+> (is_z `pcntOf` entries), + text "has z-encoding: " <+> (has_z `pcntOf` entries) + ]) + -- we usually get more "has z-encoding" than "z-encoded", because + -- when we z-encode a string it might hash to the exact same string, + -- which will is not counted as "z-encoded". Only strings whose + -- Z-encoding is different from the original string are counted in + -- the "z-encoded" total. + putMsg dflags msg + where + x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' + +countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) +countFS entries longest is_z has_z (b:bs) = + let + len = length b + longest' = max len longest + entries' = entries + len + is_zs = length (filter isZEncoded b) + has_zs = length (filter hasZEncoding b) + in + countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs -- ----------------------------------------------------------------------------- -- Util