From: krasimir Date: Tue, 5 Apr 2005 09:06:37 +0000 (+0000) Subject: [project @ 2005-04-05 09:06:36 by krasimir] X-Git-Tag: Initial_conversion_from_CVS_complete~812 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=bdfa0107143179ddd8e539306442eefeb1913d48;hp=43c2b68138397eb08aa386e2818b6cc17e94fd1e;p=ghc-hetmet.git [project @ 2005-04-05 09:06:36 by krasimir] In many places there was a common pattern when (verbose >= n) $ putMsg "..." It is now replaced with debutTraceMsg dflags n "..." In few places hPutStrLn stderr or putStrLn was used instead of putMsg in the above pattern. They are replaced too. Now putMsg is used only in places where the verbosity flag was not checked. --- diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 4b0a59b..f94314c 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -66,7 +66,7 @@ endPass dflags pass_name dump_flag binds = do -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated - debugTraceMsg dflags $ + debugTraceMsg dflags 2 $ " Result size = " ++ show (coreBindsSize binds) -- Report verbosely, if required diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 42972ea..bd0be6f 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -40,6 +40,7 @@ import Maybe ( isJust ) #if __GLASGOW_HASKELL__ <= 408 import Panic ( catchJust, ioErrors ) #endif +import ErrUtils ( debugTraceMsg ) ----------------------------------------------------------------- -- @@ -65,9 +66,7 @@ doMkDependHS session srcs ; let sorted = GHC.topSortModuleGraph False mod_summaries Nothing -- Print out the dependencies if wanted - ; if verbosity dflags >= 2 then - hPutStrLn stderr (showSDoc (text "Module dependencies" $$ ppr sorted)) - else return () + ; debugTraceMsg dflags 2 (showSDoc (text "Module dependencies" $$ ppr sorted)) -- Prcess them one by one, dumping results into makefile -- and complaining about cycles diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index fae03ac..dc45f45 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -114,12 +114,11 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary) - let verb = verbosity dflags0 let location = ms_location mod_summary let input_fn = expectJust "compile:hs" (ml_hs_file location) let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary) - when (verb >= 2) (putMsg ("compile: input file " ++ input_fnpp)) + debugTraceMsg dflags0 2 ("compile: input file " ++ input_fnpp) -- Add in the OPTIONS from the source file -- This is nasty: we've done this once already, in the compilation manager @@ -265,19 +264,16 @@ link BatchCompile dflags batch_attempt_linking hpt -- the linkables to link linkables = map (fromJust.hm_linkable) home_mod_infos - when (verb >= 3) $ do - hPutStrLn stderr "link: linkables are ..." - hPutStrLn stderr (showSDoc (vcat (map ppr linkables))) + debugTraceMsg dflags 3 "link: linkables are ..." + debugTraceMsg dflags 3 (showSDoc (vcat (map ppr linkables))) -- check for the -no-link flag if isNoLink (ghcLink dflags) - then do when (verb >= 3) $ - hPutStrLn stderr "link(batch): linking omitted (-c flag given)." + then do debugTraceMsg dflags 3 "link(batch): linking omitted (-c flag given)." return Succeeded else do - when (verb >= 1) $ - hPutStrLn stderr "Linking ..." + debugTraceMsg dflags 1 "Linking ..." let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) obj_files = concatMap getOfiles linkables @@ -285,18 +281,15 @@ link BatchCompile dflags batch_attempt_linking hpt -- Don't showPass in Batch mode; doLink will do that for us. staticLink dflags obj_files pkg_deps - when (verb >= 3) (hPutStrLn stderr "link: done") + debugTraceMsg dflags 3 "link: done" -- staticLink only returns if it succeeds return Succeeded | otherwise - = do when (verb >= 3) $ do - hPutStrLn stderr "link(batch): upsweep (partially) failed OR" - hPutStrLn stderr " Main.main not exported; not linking." + = do debugTraceMsg dflags 3 "link(batch): upsweep (partially) failed OR" + debugTraceMsg dflags 3 " Main.main not exported; not linking." return Succeeded - where - verb = verbosity dflags -- ----------------------------------------------------------------------------- diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 9e43b3f..e53e40c 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -219,9 +219,9 @@ compilationPassMsg :: DynFlags -> String -> IO () compilationPassMsg dflags msg = ifVerbose dflags 2 (putMsg msg) -debugTraceMsg :: DynFlags -> String -> IO () -debugTraceMsg dflags msg - = ifVerbose dflags 2 (putMsg msg) +debugTraceMsg :: DynFlags -> Int -> String -> IO () +debugTraceMsg dflags val msg + = ifVerbose dflags val (putMsg msg) GLOBAL_VAR(msgHandler, hPutStrLn stderr, (String -> IO ())) diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 26f598f..e2e3ab7 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -68,6 +68,9 @@ module GHC ( -- used by DriverMkDepend: sessionHscEnv, cyclicModuleErr, + + -- Exceptions + GhcException(..) ) where {- @@ -123,7 +126,7 @@ import Module import FiniteMap import Panic import Digraph -import ErrUtils ( showPass, Messages, putMsg ) +import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg ) import qualified ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) @@ -159,10 +162,10 @@ defaultErrorHandler inner = hFlush stdout case exception of -- an IO exception probably isn't our fault, so don't panic - IOException _ -> hPutStrLn stderr (show exception) + IOException _ -> putMsg (show exception) AsyncException StackOverflow -> - hPutStrLn stderr "stack overflow: use +RTS -K to increase it" - _other -> hPutStr stderr (show (Panic (show exception))) + putMsg "stack overflow: use +RTS -K to increase it" + _other -> putMsg (show (Panic (show exception))) exitWith (ExitFailure 1) ) $ @@ -172,7 +175,7 @@ defaultErrorHandler inner = case dyn of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) - _ -> do hPutStrLn stderr (show (dyn :: GhcException)) + _ -> do putMsg (show (dyn :: GhcException)) exitWith (ExitFailure 1) ) $ inner @@ -321,8 +324,8 @@ depanal (Session ref) excluded_mods = do old_graph = hsc_mod_graph hsc_env showPass dflags "Chasing dependencies" - when (verbosity dflags >= 1 && gmode == BatchCompile) $ - hPutStrLn stderr (showSDoc (hcat [ + when (gmode == BatchCompile) $ + debugTraceMsg dflags 1 (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))])) @@ -401,8 +404,7 @@ load s@(Session ref) how_much evaluate pruned_hpt - when (verb >= 2) $ - putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ + debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco)) -- Unload any modules which are going to be re-linked this time around. @@ -480,7 +482,7 @@ load s@(Session ref) how_much then -- Easy; just relink it all. - do when (verb >= 2) $ putMsg "Upsweep completely successful." + do debugTraceMsg dflags 2 "Upsweep completely successful." -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) @@ -501,9 +503,8 @@ load s@(Session ref) how_much mod_graph do_linking = a_root_is_Main || no_hs_main - when (ghci_mode == BatchCompile && isJust ofile && not do_linking - && verb > 0) $ - putMsg ("Warning: output was redirected with -o, " ++ + when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ + debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ main_mod ++ " module.") @@ -516,7 +517,7 @@ load s@(Session ref) how_much -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do when (verb >= 2) $ putMsg "Upsweep partially successful." + do debugTraceMsg dflags 2 "Upsweep partially successful." let modsDone_names = map ms_mod modsDone @@ -814,7 +815,7 @@ upsweep hsc_env old_hpt stable_mods cleanup upsweep hsc_env old_hpt stable_mods cleanup (CyclicSCC ms:_) - = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms)) + = do putMsg (showSDoc (cyclicModuleErr ms)) return (Failed, hsc_env, []) upsweep hsc_env old_hpt stable_mods cleanup diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 45b0835..911da2f 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -60,7 +60,6 @@ import Compat.Directory ( getAppUserDataDirectory ) import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version -import System.IO ( hPutStrLn, stderr ) import Data.Maybe ( isNothing ) import System.Directory ( doesFileExist ) import Control.Monad ( when, foldM ) @@ -73,6 +72,7 @@ import Data.List ( isPrefixOf ) import FastString import DATA_IOREF import EXCEPTION ( throwDyn ) +import ErrUtils ( debugTraceMsg, putMsg ) -- --------------------------------------------------------------------------- -- The Package state @@ -225,9 +225,7 @@ readPackageConfigs dflags = do readPackageConfig :: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap readPackageConfig dflags pkg_map conf_file = do - when (verbosity dflags >= 2) $ - hPutStrLn stderr ("Using package config file: " - ++ conf_file) + debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file) proto_pkg_configs <- loadPackageConfig conf_file top_dir <- getTopDir let pkg_configs = mungePackagePaths top_dir proto_pkg_configs @@ -566,6 +564,6 @@ dumpPackages :: DynFlags -> IO () -- Show package info on console, if verbosity is >= 3 dumpPackages dflags = do let pkg_map = pkgIdMap (pkgState dflags) - hPutStrLn stderr $ showSDoc $ + putMsg $ showSDoc $ vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) \end{code} diff --git a/ghc/compiler/main/StaticFlags.hs b/ghc/compiler/main/StaticFlags.hs index 0d01001..512f52c 100644 --- a/ghc/compiler/main/StaticFlags.hs +++ b/ghc/compiler/main/StaticFlags.hs @@ -87,7 +87,6 @@ import DATA_IOREF import UNSAFE_IO ( unsafePerformIO ) import Monad ( when ) import Char ( isDigit ) -import IO ( hPutStrLn, stderr ) -- ToDo: should use errorMsg import List ( sort, intersperse ) ----------------------------------------------------------------------------- diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 1033f6a..e94ca9d 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -47,7 +47,7 @@ module SysTools ( import DriverPhases ( isHaskellUserSrcFilename ) import Config import Outputable -import ErrUtils ( putMsg ) +import ErrUtils ( putMsg, debugTraceMsg ) import Panic ( GhcException(..) ) import Util ( Suffix, global, notNull, consIORef, normalisePath, pgmPath, platformPath ) @@ -61,7 +61,7 @@ import DATA_INT import Monad ( when, unless ) import System ( ExitCode(..), getEnv, system ) import IO ( try, catch, - openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..), + openFile, hPutStr, hClose, hFlush, IOMode(..), stderr ) import Directory ( doesFileExist, removeFile ) import List ( partition ) @@ -490,7 +490,7 @@ touch dflags purpose arg = do copy :: DynFlags -> String -> String -> String -> IO () copy dflags purpose from to = do - when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose) + debugTraceMsg dflags 2 ("*** " ++ purpose) h <- openFile to WriteMode ls <- readFile from -- inefficient, but it'll do for now. @@ -562,8 +562,6 @@ removeTmpFiles dflags fs ("Deleting: " ++ unwords deletees) (mapM_ rm deletees) where - verb = verbosity dflags - -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source -- files?) @@ -573,15 +571,14 @@ removeTmpFiles dflags fs warnNon act | null non_deletees = act | otherwise = do - hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees) + putMsg ("WARNING - NOT deleting source files: " ++ unwords non_deletees) act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs rm f = removeFile f `IO.catch` (\_ignored -> - when (verb >= 2) $ - hPutStrLn stderr ("Warning: deleting non-existent " ++ f) + debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f) ) @@ -622,8 +619,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO () -- b) don't do it at all if dry-run is set traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags - ; when (verb >= 2) $ putMsg ("*** " ++ phase_name) - ; when (verb >= 3) $ putMsg cmd_line + ; debugTraceMsg dflags 2 ("*** " ++ phase_name) + ; debugTraceMsg dflags 3 cmd_line ; hFlush stderr -- Test for -n flag @@ -633,8 +630,8 @@ traceCmd dflags phase_name cmd_line action ; action `IO.catch` handle_exn verb }} where - handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n") - ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn))) + handle_exn verb exn = do { debugTraceMsg dflags 2 "\n" + ; debugTraceMsg dflags 2 ("Failed: " ++ cmd_line ++ (show exn)) ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) } \end{code}