= 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
#if __GLASGOW_HASKELL__ <= 408
import Panic ( catchJust, ioErrors )
#endif
+import ErrUtils ( debugTraceMsg )
-----------------------------------------------------------------
--
; 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
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
-- 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
-- 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
-- -----------------------------------------------------------------------------
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 ()))
-- used by DriverMkDepend:
sessionHscEnv,
cyclicModuleErr,
+
+ -- Exceptions
+ GhcException(..)
) where
{-
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 )
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<size> to increase it"
- _other -> hPutStr stderr (show (Panic (show exception)))
+ putMsg "stack overflow: use +RTS -K<size> to increase it"
+ _other -> putMsg (show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
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
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))]))
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.
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)
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.")
-- 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
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
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 )
import FastString
import DATA_IOREF
import EXCEPTION ( throwDyn )
+import ErrUtils ( debugTraceMsg, putMsg )
-- ---------------------------------------------------------------------------
-- The Package state
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
-- 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}
import UNSAFE_IO ( unsafePerformIO )
import Monad ( when )
import Char ( isDigit )
-import IO ( hPutStrLn, stderr ) -- ToDo: should use errorMsg
import List ( sort, intersperse )
-----------------------------------------------------------------------------
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 )
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 )
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.
("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?)
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)
)
-- 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
; 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}
projects / ghc-hetmet.git / commitdiff