Mostly verbosity changes.
GONE AWAY: -dshow-passes, -ddump-all, -ddump-most.
NEW:
-v<n>, where <n> is
0 | print errors & warnings only
1 | minimal verbosity: print "compiling M ... done." for each module.
2 | equivalent to -dshow-passes
3 | equivalent to existing "ghc -v"
4 | "ghc -v -ddump-most"
5 | "ghc -v -ddump-all"
4 & 5 are the same at the moment. -dshow-passes also prints out the
passes in the driver, and some in the compilation manager.
import Outputable ( SDoc )
import Digraph ( SCC(..), flattenSCC )
import DriverUtil
-import Module ( ModuleName, PackageName )
+import Module ( ModuleName )
import RdrName
import FiniteMap
import Outputable
+import ErrUtils ( showPass )
+import CmdLineOpts ( DynFlags(..) )
import Panic ( panic )
import Exception
+import Monad
import IO
#include "HsVersions.h"
\begin{code}
link :: GhciMode -- interactive or batch
+ -> DynFlags -- dynamic flags
-> Bool -- attempt linking in batch mode?
-> [Linkable] -- only contains LMs, not LPs
-> PersistentLinkerState
-- to be actually linked this time around (or unlinked and re-linked
-- if the module was recompiled).
-link mode batch_attempt_linking linkables pls1
- = do hPutStrLn stderr "CmLink.link: linkables are ..."
- hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
- res <- link' mode batch_attempt_linking linkables pls1
- hPutStrLn stderr "CmLink.link: done"
+link mode dflags batch_attempt_linking linkables pls1
+ = do let verb = verbosity dflags
+ when (verb >= 3) $ do
+ hPutStrLn stderr "CmLink.link: linkables are ..."
+ hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
+ res <- link' mode dflags batch_attempt_linking linkables pls1
+ when (verb >= 3) $
+ hPutStrLn stderr "CmLink.link: done"
return res
-link' Batch batch_attempt_linking linkables pls1
+link' Batch dflags batch_attempt_linking linkables pls1
| batch_attempt_linking
= do let o_files = concatMap getOfiles linkables
+ -- don't showPass in Batch mode; doLink will do that for us.
doLink o_files
-- doLink only returns if it succeeds
return (LinkOK pls1)
| otherwise
- = do hPutStrLn stderr "CmLink.link(batch): upsweep (partially?) failed OR main not exported;"
- hPutStrLn stderr " -- not doing linking"
+ = do let verb = verbosity dflags
+ when (verb >= 3) $ do
+ hPutStrLn stderr "CmLink.link(batch): upsweep (partially?) failed OR main not exported;"
+ hPutStrLn stderr "not linking."
return (LinkOK pls1)
where
getOfiles (LP _) = panic "CmLink.link(getOfiles): shouldn't get package linkables"
getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
-link' Interactive batch_attempt_linking linkables pls1
- = linkObjs linkables pls1
-
+link' Interactive dflags batch_attempt_linking linkables pls1
+ = do showPass dflags "Linking"
+ pls2 <- unload pls1
+ linkObjs linkables pls2
+
ppLinkableSCC :: SCC Linkable -> SDoc
ppLinkableSCC = ppr . flattenSCC
closure_env = new_closure_env,
itbl_env = new_itbl_env
}
- putStrLn (showSDoc (vcat (map ppr (keysFM new_closure_env))))
return (LinkOK new_pls)
-- purge the current "linked image"
UniqFM, listToUFM )
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp )
+import DriverFlags ( getDynFlags )
import DriverPhases
import DriverUtil ( BarfKind(..), splitFilename3 )
+import ErrUtils ( showPass )
import Util
import Outputable
import Panic ( panic )
#ifdef GHCI
-import CmdLineOpts ( DynFlags )
+import CmdLineOpts ( DynFlags(..) )
import Interpreter ( HValue )
import HscMain ( hscExpr )
import RdrName
import Time ( ClockTime )
import Directory ( getModificationTime, doesFileExist )
import IO
+import Monad
import List ( nub )
import Maybe ( catMaybes, fromMaybe, isJust )
\end{code}
-- Throw away the old home dir cache
emptyHomeDirCache
- hPutStrLn stderr ("ghc: chasing modules, starting from: " ++ rootname)
+ dflags <- getDynFlags
+ let verb = verbosity dflags
+
+ showPass dflags "Chasing dependencies"
+
mg2unsorted <- downsweep [rootname]
let modnames1 = map name_of_summary mg1
then
-- Easy; just relink it all.
- do hPutStrLn stderr "UPSWEEP COMPLETELY SUCCESSFUL"
+ do when (verb >= 2) $
+ hPutStrLn stderr "Upsweep completely successful."
linkresult
- <- link ghci_mode (any exports_main (moduleEnvElts hst3))
- newLis pls1
+ <- link ghci_mode dflags
+ (any exports_main (moduleEnvElts hst3))
+ newLis pls1
case linkresult of
LinkErrs _ _
-> panic "cmLoadModule: link failed (1)"
-- 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 hPutStrLn stderr "UPSWEEP PARTIALLY SUCCESSFUL"
+ do when (verb >= 2) $
+ hPutStrLn stderr "Upsweep partially successful."
let modsDone_names
= map name_of_summary modsDone
= map (unJust "linkables_to_link" . findModuleLinkable_maybe ui4)
mods_to_keep_names
- linkresult <- link ghci_mode False linkables_to_link pls1
+ linkresult <- link ghci_mode dflags False linkables_to_link pls1
case linkresult of
LinkErrs _ _
-> panic "cmLoadModule: link failed (2)"
upsweep_mods ghci_mode oldUI reachable_from threaded
((CyclicSCC ms):_)
- = do hPutStrLn stderr ("ghc: module imports form a cycle for modules:\n\t" ++
+ = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
unwords (map (moduleNameUserString.name_of_summary) ms))
return (False, threaded, [], [])
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message, showPass,
+import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message, showPass,
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
import SrcLoc ( SrcLoc, noSrcLoc )
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
- if dopt Opt_D_show_passes dflags then
+ if verbosity dflags >= 2 then
hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
else
return ()
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
- done_lint = doIfSet_dyn dflags Opt_D_show_passes
+ done_lint = doIfSet (verbosity dflags >= 2)
(hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
warn warnings
= vcat [
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.7 2000/11/21 10:48:20 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.8 2000/11/21 14:32:44 simonmar Exp $
--
-- GHC Interactive User Interface
--
Readline.initialize
#endif
_ <- (unGHCi uiLoop) GHCiState{ modules = [],
- current_module = Nothing,
+ current_module = defaultCurrentModule,
target = Nothing,
cmstate = st }
return ()
uiLoop = do
st <- getGHCiState
#ifndef NO_READLINE
- l <- io (readline (mkPrompt (current_module st) ++ "> "))
+ l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
#else
l <- io (hGetLine stdin)
#endif
runCommand l
uiLoop
-mkPrompt Nothing = ""
-mkPrompt (Just mod_name) = moduleNameUserString mod_name
-
-- Top level exception handler, just prints out the exception
-- and carries on.
runCommand c =
doCommand c
doCommand (':' : command) = specialCommand command
-doCommand expr = do
- st <- getGHCiState
- case current_module st of
- Nothing -> throwDyn (OtherError "no module context in which to run the expression")
- Just mod -> do
- dflags <- io (readIORef v_DynFlags)
- (new_cmstate, maybe_hvalue) <-
- io (cmGetExpr (cmstate st) dflags mod expr)
- setGHCiState st{cmstate = new_cmstate}
- case maybe_hvalue of
- Nothing -> return ()
- Just hv -> io (cmRunExpr hv)
+doCommand expr
+ = do st <- getGHCiState
+ dflags <- io (readIORef v_DynFlags)
+ (new_cmstate, maybe_hvalue) <-
+ io (cmGetExpr (cmstate st) dflags (current_module st) expr)
+ setGHCiState st{cmstate = new_cmstate}
+ case maybe_hvalue of
+ Nothing -> return ()
+ Just hv -> io (cmRunExpr hv)
{-
let (mod,'.':str) = break (=='.') expr
case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
cmstate = new_cmstate,
modules = mods,
current_module = case mods of
- [] -> Nothing
- xs -> Just (last xs),
+ [] -> defaultCurrentModule
+ xs -> last xs,
target = Just path
}
setGHCiState new_state
data GHCiState = GHCiState
{
modules :: [ModuleName],
- current_module :: Maybe ModuleName,
+ current_module :: ModuleName,
target :: Maybe FilePath,
cmstate :: CmState
}
+defaultCurrentModule = mkModuleName "Prelude"
+
newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
instance Monad GHCi where
SimplifierSwitch(..), isAmongSimpl,
StgToDo(..),
SwitchResult(..),
+
HscLang(..),
DynFlag(..), -- needed non-abstractly by DriverFlags
DynFlags(..),
+ defaultDynFlags,
v_Static_hsc_opts,
data DynFlag
-- debugging flags
- = Opt_D_dump_all
- | Opt_D_dump_most
- | Opt_D_dump_absC
+ = Opt_D_dump_absC
| Opt_D_dump_asm
| Opt_D_dump_cpranal
| Opt_D_dump_deriv
| Opt_D_dump_usagesp
| Opt_D_dump_cse
| Opt_D_dump_worker_wrapper
- | Opt_D_show_passes
| Opt_D_dump_rn_trace
| Opt_D_dump_rn_stats
| Opt_D_dump_stix
stgToDo :: [StgToDo],
hscLang :: HscLang,
hscOutName :: String, -- name of the file in which to place output
+ verbosity :: Int, -- verbosity level
flags :: [DynFlag]
}
+defaultDynFlags = DynFlags {
+ coreToDo = [], stgToDo = [],
+ hscLang = HscC, hscOutName = "",
+ verbosity = 0, flags = []
+ }
+
+{-
+ Verbosity levels:
+
+ 0 | print errors & warnings only
+ 1 | minimal verbosity: print "compiling M ... done." for each module.
+ 2 | equivalent to -dshow-passes
+ 3 | equivalent to existing "ghc -v"
+ 4 | "ghc -v -ddump-most"
+ 5 | "ghc -v -ddump-all"
+-}
+
dopt :: DynFlag -> DynFlags -> Bool
dopt f dflags = f `elem` (flags dflags)
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.20 2000/11/19 19:40:08 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.21 2000/11/21 14:34:29 simonmar Exp $
--
-- Driver flags
--
import Exception
import IOExts
import IO
+import Monad
import System
import Char
exitWith ExitSuccess))
------- verbosity ----------------------------------------------------
- , ( "v" , NoArg (writeIORef v_Verbose True) )
, ( "n" , NoArg (writeIORef v_Dry_run True) )
------- recompilation checker --------------------------------------
-----------------------------------------------------------------------------
-- parse the dynamic arguments
-GLOBAL_VAR(v_InitDynFlags, error "no InitDynFlags", DynFlags)
-GLOBAL_VAR(v_DynFlags, error "no DynFlags", DynFlags)
+-- v_InitDynFlags
+-- is the "baseline" dynamic flags, initialised from
+-- the defaults and command line options.
+--
+-- v_DynFlags
+-- is the dynamic flags for the current compilation. It is reset
+-- to the value of v_InitDynFlags before each compilation, then
+-- updated by reading any OPTIONS pragma in the current module.
-setDynFlag f = do
- dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags dfs{ flags = f : flags dfs }
+GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
+GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
-unSetDynFlag f = do
+updDynFlags f = do
dfs <- readIORef v_DynFlags
- writeIORef v_DynFlags dfs{ flags = filter (/= f) (flags dfs) }
+ writeIORef v_DynFlags (f dfs)
+
+getDynFlags :: IO DynFlags
+getDynFlags = readIORef v_DynFlags
+
+dynFlag :: (DynFlags -> a) -> IO a
+dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
+
+setDynFlag f = updDynFlags (\dfs -> dfs{ flags = f : flags dfs })
+unSetDynFlag f = updDynFlags (\dfs -> dfs{ flags = filter (/= f) (flags dfs) })
-- we can only change HscC to HscAsm and vice-versa with dynamic flags
-- (-fvia-C and -fasm).
HscAsm -> writeIORef v_DynFlags dfs{ hscLang = l }
_ -> return ()
+setVerbosityAtLeast n =
+ updDynFlags (\dfs -> if verbosity dfs < n
+ then dfs{ verbosity = n }
+ else dfs)
+
+setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 2 })
+setVerbosity n
+ | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n })
+ | otherwise = throwDyn (OtherError "can't parse verbosity flag (-v<n>)")
+
+getVerbFlag = do
+ verb <- dynFlag verbosity
+ if verb >= 3 then return "-v" else return ""
+
dynamic_flags = [
( "cpp", NoArg (updateState (\s -> s{ cpp_flag = True })) )
, ( "#include", HasArg (addCmdlineHCInclude) )
+ , ( "v", OptPrefix (setVerbosity) )
+
, ( "optL", HasArg (addOpt_L) )
, ( "optP", HasArg (addOpt_P) )
, ( "optc", HasArg (addOpt_c) )
------ Debugging ----------------------------------------------------
, ( "dstg-stats", NoArg (writeIORef v_StgStats True) )
- , ( "ddump-all", NoArg (setDynFlag Opt_D_dump_all) )
- , ( "ddump-most", NoArg (setDynFlag Opt_D_dump_most) )
, ( "ddump-absC", NoArg (setDynFlag Opt_D_dump_absC) )
, ( "ddump-asm", NoArg (setDynFlag Opt_D_dump_asm) )
, ( "ddump-cpranal", NoArg (setDynFlag Opt_D_dump_cpranal) )
, ( "ddump-usagesp", NoArg (setDynFlag Opt_D_dump_usagesp) )
, ( "ddump-cse", NoArg (setDynFlag Opt_D_dump_cse) )
, ( "ddump-worker-wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
- , ( "dshow-passes", NoArg (setDynFlag Opt_D_show_passes) )
+ , ( "dshow-passes", NoArg (setVerbosity "2") )
, ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace) )
, ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) )
, ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) )
else return "")
return ( static : filtered_opts )
+
+-----------------------------------------------------------------------------
+-- Running an external program
+
+-- sigh, here because both DriverMkDepend & DriverPipeline need it.
+
+runSomething phase_name cmd
+ = do
+ verb <- dynFlag verbosity
+ when (verb >= 2) $ putStr ("*** " ++ phase_name)
+ when (verb >= 3) $ putStrLn cmd
+ hFlush stdout
+
+ -- test for -n flag
+ n <- readIORef v_Dry_run
+ unless n $ do
+
+ -- and run it!
+#ifndef mingw32_TARGET_OS
+ exit_code <- system cmd `catchAllIO`
+ (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+#else
+ tmp <- newTempName "sh"
+ h <- openFile tmp WriteMode
+ hPutStrLn h cmd
+ hClose h
+ exit_code <- system ("sh - " ++ tmp) `catchAllIO`
+ (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ removeFile tmp
+#endif
+
+ if exit_code /= ExitSuccess
+ then throwDyn (PhaseFailed phase_name exit_code)
+ else do when (verb >= 3) (putStr "\n")
+ return ()
+
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.5 2000/11/15 15:43:31 sewardj Exp $
+-- $Id: DriverMkDepend.hs,v 1.6 2000/11/21 14:34:47 simonmar Exp $
--
-- GHC Driver
--
-- create a backup of the original makefile
when (isJust makefile_hdl) $
- run_something ("Backing up " ++ makefile)
+ runSomething ("Backing up " ++ makefile)
(unwords [ "cp", makefile, makefile++".bak" ])
-- copy the new makefile in place
- run_something "Installing new makefile"
+ runSomething "Installing new makefile"
(unwords [ "cp", tmp_file, makefile ])
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.33 2000/11/20 17:42:00 sewardj Exp $
+-- $Id: DriverPipeline.hs,v 1.34 2000/11/21 14:34:50 simonmar Exp $
--
-- GHC Driver
--
import HscTypes
import Outputable
import Module
+import ErrUtils
import CmdLineOpts
import Config
import Util
run_phase Unlit _basename _suff input_fn output_fn
= do unlit <- readIORef v_Pgm_L
unlit_flags <- getOpts opt_L
- run_something "Literate pre-processor"
+ runSomething "Literate pre-processor"
("echo '# 1 \"" ++input_fn++"\"' > "++output_fn++" && "
++ unlit ++ ' ':input_fn ++ " - >> " ++ output_fn)
return True
let include_paths = map (\p -> "-I"++p) (cmdline_include_paths
++ pkg_include_dirs)
- verb <- is_verbose
- run_something "C pre-processor"
+ verb <- getVerbFlag
+
+ runSomething "C pre-processor"
(unwords
(["echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}'", ">", output_fn, "&&",
cpp, verb]
++ [ "-x", "c", input_fn, ">>", output_fn ]
))
else do
- run_something "Ineffective C pre-processor"
+ runSomething "Ineffective C pre-processor"
("echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}' > "
++ output_fn ++ " && cat " ++ input_fn
++ " >> " ++ output_fn)
mangle <- readIORef v_Do_asm_mangling
(md_c_flags, md_regd_c_flags) <- machdepCCOpts
- verb <- is_verbose
+ verb <- getVerbFlag
o2 <- readIORef v_minus_o2_for_C
let opt_flag | o2 = "-O2"
excessPrecision <- readIORef v_Excess_precision
- run_something "C Compiler"
+ runSomething "C Compiler"
(unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
++ md_c_flags
++ (if cc_phase == HCc && mangle
then do n_regs <- readState stolen_x86_regs
return [ show n_regs ]
else return []
- run_something "Assembly Mangler"
+ runSomething "Assembly Mangler"
(unwords (mangler :
mangler_opts
++ [ input_fn, output_fn ]
-- allocate a tmp file to put the no. of split .s files in (sigh)
n_files <- newTempName "n_files"
- run_something "Split Assembly File"
+ runSomething "Split Assembly File"
(unwords [ splitter
, input_fn
, split_s_prefix
cmdline_include_paths <- readIORef v_Include_paths
let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
- run_something "Assembler"
+ runSomething "Assembler"
(unwords (as : as_opts
++ cmdline_include_flags
++ [ "-c", input_fn, "-o", output_fn ]
let output_o = newdir real_odir
(basename ++ "__" ++ show n ++ ".o")
real_o <- osuf_ify output_o
- run_something "Assembler"
+ runSomething "Assembler"
(unwords (as : as_opts
++ [ "-c", "-o", real_o, input_s ]
))
doLink :: [String] -> IO ()
doLink o_files = do
ln <- readIORef v_Pgm_l
- verb <- is_verbose
+ verb <- getVerbFlag
static <- readIORef v_Static
let imp = if static then "" else "_imp"
no_hs_main <- readIORef v_NoHsMain
else []
#endif
(md_c_flags, _) <- machdepCCOpts
- run_something "Linker"
+ runSomething "Linker"
(unwords
([ ln, verb, "-o", output_fn ]
++ md_c_flags
compile ghci_mode summary source_unchanged old_iface hst hit pcs = do
- verb <- readIORef v_Verbose
- when verb (hPutStrLn stderr
- (showSDoc (text "compile: compiling"
- <+> ppr (name_of_summary summary))))
-
init_dyn_flags <- readIORef v_InitDynFlags
writeIORef v_DynFlags init_dyn_flags
init_driver_state <- readIORef v_InitDriverState
writeIORef v_Driver_state init_driver_state
+ showPass init_dyn_flags (showSDoc (text "*** Compiling: "
+ <+> ppr (name_of_summary summary)))
+
+ let verb = verbosity init_dyn_flags
let location = ms_location summary
let input_fn = unJust "compile:hs" (ml_hs_file location)
let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
- when verb (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
+ when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
opts <- getOptionsFromSource input_fnpp
processArgs dynamic_flags opts []
case maybe_stub_h of
Nothing -> return ()
Just tmp_stub_h -> do
- run_something "Copy stub .h file"
+ runSomething "Copy stub .h file"
("cp " ++ tmp_stub_h ++ ' ':stub_h)
-- #include <..._stub.h> in .hc file
case maybe_stub_c of
Nothing -> return Nothing
Just tmp_stub_c -> do -- copy the _stub.c file into the current dir
- run_something "Copy stub .c file"
+ runSomething "Copy stub .c file"
(unwords [
"rm -f", stub_c, "&&",
"echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.15 2000/11/19 19:40:08 simonmar Exp $
+-- $Id: DriverState.hs,v 1.16 2000/11/21 14:35:05 simonmar Exp $
--
-- Settings for the driver
--
]
{-# NOINLINE v_Hs_source_cpp_opts #-}
--- Verbose
-GLOBAL_VAR(v_Verbose, False, Bool)
-is_verbose = do v <- readIORef v_Verbose; if v then return "-v" else return ""
-
-- Keep output from intermediate phases
GLOBAL_VAR(v_Keep_hi_diffs, False, Bool)
GLOBAL_VAR(v_Keep_hc_files, False, Bool)
| otherwise
= return ( [], [] )
-
-
------------------------------------------------------------------------------
--- Running an external program
-
-run_something phase_name cmd
- = do
- verb <- readIORef v_Verbose
- when verb $ do
- putStr phase_name
- putStrLn ":"
- putStrLn cmd
- hFlush stdout
-
- -- test for -n flag
- n <- readIORef v_Dry_run
- unless n $ do
-
- -- and run it!
-#ifndef mingw32_TARGET_OS
- exit_code <- system cmd `catchAllIO`
- (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
-#else
- tmp <- newTempName "sh"
- h <- openFile tmp WriteMode
- hPutStrLn h cmd
- hClose h
- exit_code <- system ("sh - " ++ tmp) `catchAllIO`
- (\e -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
- removeFile tmp
-#endif
-
- if exit_code /= ExitSuccess
- then throwDyn (PhaseFailed phase_name exit_code)
- else do when verb (putStr "\n")
- return ()
-
import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc )
import Util ( sortLt )
import Outputable
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
+import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt )
import System ( ExitCode(..), exitWith )
import IO ( hPutStr, stderr )
\begin{code}
showPass :: DynFlags -> String -> IO ()
showPass dflags what
- | dopt Opt_D_show_passes dflags = hPutStr stderr ("*** "++what++":\n")
- | otherwise = return ()
+ | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n")
+ | otherwise = return ()
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
- | not (dopt flag dflags) = return ()
- | otherwise = printDump (dump hdr doc)
+ | not (dopt flag dflags) && verbosity dflags < 4 = return ()
+ | otherwise = printDump (dump hdr doc)
dump hdr doc
= vcat [text "",
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Util ( unJust )
+import Unique ( Uniquable(..) )
+import PrelNames ( ioTyConKey )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( emptyBag )
HomeSymbolTable,
OrigNameEnv(..), PackageRuleBase, HomeIfaceTable,
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
+import Type ( splitTyConApp_maybe )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName )
<- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
case maybe_tc_return of
Nothing -> return (pcs1, Nothing)
- Just (pcs2, tc_expr) -> do {
+ Just (pcs2, tc_expr, ty) -> do {
+
+ let { is_IO_type = case splitTyConApp_maybe ty of {
+ Just (tycon, _) -> getUnique tycon == ioTyConKey;
+ Nothing -> False }
+ };
+
+ if (not is_IO_type)
+ then hscExpr dflags hst hit pcs2 this_module
+ ("print (" ++ expr ++ ")")
+ else do
-- Desugar it
ds_expr <- deSugarExpr dflags pcs2 hst this_module
-- of the string...)
let glaexts = 1#
--let glaexts | dopt Opt_GlasgowExts dflags = 1#
- -- | otherwise = 0#
+ -- | otherwise = 0#
case parse buf PState{ bol = 0#, atbol = 1#,
context = [], glasgow_exts = glaexts,
loc = mkSrcLoc SLIT("<no file>") 0 } of {
- PFailed err -> do { freeStringBuffer buf
- ; hPutStrLn stderr (showSDoc err)
- ; return Nothing };
+ PFailed err -> do { freeStringBuffer buf;
+ hPutStrLn stderr (showSDoc err);
+ return Nothing };
POk _ (PExpr rdr_expr) -> do {
- -- ToDo:
- -- freeStringBuffer buf;
-
+ --ToDo: can't free the string buffer until we've finished this
+ -- compilation sweep and all the identifiers have gone away.
+ --freeStringBuffer buf;
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_expr);
-
return (Just rdr_expr)
}}
#endif
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.28 2000/11/20 16:37:42 sewardj Exp $
+-- $Id: Main.hs,v 1.29 2000/11/21 14:35:52 simonmar Exp $
--
-- GHC Driver program
--
-- make sure we clean up after ourselves
later (do forget_it <- readIORef v_Keep_tmp_files
unless forget_it $ do
- verb <- readIORef v_Verbose
- cleanTempFiles verb
+ verb <- dynFlag verbosity
+ cleanTempFiles (verb >= 2)
) $ do
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
hscLang = lang,
-- leave out hscOutName for now
hscOutName = panic "Main.main:hscOutName not set",
+
+ verbosity = case mode of
+ DoInteractive -> 1
+ DoMake -> 1
+ _other -> 0,
+
flags = [] }
-- the rest of the arguments are "dynamic"
saved_driver_state <- readIORef v_Driver_state
writeIORef v_InitDriverState saved_driver_state
- -- get the -v flag
- verb <- readIORef v_Verbose
+ verb <- dynFlag verbosity
- when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
- hPutStr stderr cProjectVersion
- hPutStr stderr ", for Haskell 98, compiled by GHC version "
- hPutStrLn stderr cBooterVersion)
+ when (verb >= 2)
+ (do hPutStr stderr "Glasgow Haskell Compiler, Version "
+ hPutStr stderr cProjectVersion
+ hPutStr stderr ", for Haskell 98, compiled by GHC version "
+ hPutStrLn stderr cBooterVersion)
- when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
+ when (verb >= 2)
+ (hPutStrLn stderr ("Using package config file: " ++ conf_file))
-- initialise the finder
initFinder pkg_details
import TcMonad
-import TcType ( newTyVarTy )
+import TcType ( newTyVarTy, zonkTcType )
import Inst ( plusLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
-> Module
-> (RenamedHsExpr, -- The expression itself
[RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
- -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr))
+ -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
= typecheck dflags pcs hst unqual $
newTyVarTy openTypeKind `thenTc` \ ty ->
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
tcSimplifyTop lie `thenTc` \ binds ->
- returnTc (new_pcs, mkHsLet binds expr')
+ zonkTcType ty `thenNF_Tc` \ zonked_ty ->
+ returnTc (new_pcs, mkHsLet binds expr', zonked_ty)
where
get_fixity :: Name -> Maybe Fixity
get_fixity n = pprPanic "typecheckExpr" (ppr n)
projects / ghc-hetmet.git / commitdiff