From: simonmar Date: Tue, 21 Nov 2000 14:36:11 +0000 (+0000) Subject: [project @ 2000-11-21 14:31:58 by simonmar] X-Git-Tag: Approximately_9120_patches~3284 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e663f7b8508aac0df712250bee90488429fcbad6;p=ghc-hetmet.git [project @ 2000-11-21 14:31:58 by simonmar] Mostly verbosity changes. GONE AWAY: -dshow-passes, -ddump-all, -ddump-most. NEW: -v, where 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. --- diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 247d2f5..c4cb9fc 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -25,13 +25,16 @@ import CmStaticInfo ( GhciMode(..) ) 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" @@ -83,6 +86,7 @@ emptyPLS = return (PersistentLinkerState {}) \begin{code} link :: GhciMode -- interactive or batch + -> DynFlags -- dynamic flags -> Bool -- attempt linking in batch mode? -> [Linkable] -- only contains LMs, not LPs -> PersistentLinkerState @@ -107,30 +111,38 @@ link :: GhciMode -- interactive or batch -- 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 @@ -202,7 +214,6 @@ linkFinish pls mods ul_trees = do 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" diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index abcdf6e..bb08b7b 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -34,14 +34,16 @@ import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, 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 @@ -55,6 +57,7 @@ import Exception ( throwDyn ) import Time ( ClockTime ) import Directory ( getModificationTime, doesFileExist ) import IO +import Monad import List ( nub ) import Maybe ( catMaybes, fromMaybe, isJust ) \end{code} @@ -175,7 +178,11 @@ cmLoadModule cmstate1 rootname -- 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 @@ -225,10 +232,12 @@ cmLoadModule cmstate1 rootname 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)" @@ -244,7 +253,8 @@ cmLoadModule cmstate1 rootname -- 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 @@ -262,7 +272,7 @@ cmLoadModule cmstate1 rootname = 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)" @@ -342,7 +352,7 @@ upsweep_mods ghci_mode oldUI reachable_from threaded 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, [], []) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 5a0c140..f932db4 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -27,7 +27,7 @@ import VarSet 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 ) @@ -72,7 +72,7 @@ endPassWithRules dflags pass_name dump_flag binds rules -- 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 () @@ -148,7 +148,7 @@ lintCoreBindings dflags whoDunnit binds 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 [ diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 2597192..39bbe01 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -82,7 +82,7 @@ interactiveUI st = do Readline.initialize #endif _ <- (unGHCi uiLoop) GHCiState{ modules = [], - current_module = Nothing, + current_module = defaultCurrentModule, target = Nothing, cmstate = st } return () @@ -91,7 +91,7 @@ uiLoop :: GHCi () 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 @@ -105,9 +105,6 @@ uiLoop = do 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 = @@ -123,18 +120,15 @@ 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 @@ -175,8 +169,8 @@ loadModule path = do 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 @@ -236,11 +230,13 @@ shellEscape str = io (system str >> return ()) 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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index cca0830..bf00769 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -10,9 +10,11 @@ module CmdLineOpts ( SimplifierSwitch(..), isAmongSimpl, StgToDo(..), SwitchResult(..), + HscLang(..), DynFlag(..), -- needed non-abstractly by DriverFlags DynFlags(..), + defaultDynFlags, v_Static_hsc_opts, @@ -214,9 +216,7 @@ data SimplifierSwitch 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 @@ -239,7 +239,6 @@ data DynFlag | 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 @@ -285,9 +284,27 @@ data DynFlags = DynFlags { 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) diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 6c86b7a..cf336d0 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -22,6 +22,7 @@ import Util import Exception import IOExts import IO +import Monad import System import Char @@ -152,7 +153,6 @@ static_flags = exitWith ExitSuccess)) ------- verbosity ---------------------------------------------------- - , ( "v" , NoArg (writeIORef v_Verbose True) ) , ( "n" , NoArg (writeIORef v_Dry_run True) ) ------- recompilation checker -------------------------------------- @@ -295,16 +295,30 @@ static_flags = ----------------------------------------------------------------------------- -- 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). @@ -315,11 +329,27 @@ setLang l = do 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)") + +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) ) @@ -333,8 +363,6 @@ dynamic_flags = [ ------ 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) ) @@ -358,7 +386,7 @@ dynamic_flags = [ , ( "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) ) @@ -470,3 +498,39 @@ buildStaticHscOpts = do 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 () + diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 15459f5..453dda1 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -155,11 +155,11 @@ endMkDependHS = do -- 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 ]) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 1e7adfe..16db45d 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -35,6 +35,7 @@ import TmpFiles import HscTypes import Outputable import Module +import ErrUtils import CmdLineOpts import Config import Util @@ -288,7 +289,7 @@ pipeLoop ((phase, keep, o_suffix):phases) 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 @@ -318,8 +319,9 @@ run_phase Cpp basename suff input_fn output_fn 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] @@ -329,7 +331,7 @@ run_phase Cpp basename suff input_fn output_fn ++ [ "-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) @@ -525,7 +527,7 @@ run_phase cc_phase _basename _suff 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" @@ -539,7 +541,7 @@ run_phase cc_phase _basename _suff input_fn output_fn 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 @@ -572,7 +574,7 @@ run_phase Mangle _basename _suff input_fn output_fn 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 ] @@ -596,7 +598,7 @@ run_phase SplitMangle _basename _suff 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 @@ -618,7 +620,7 @@ run_phase As _basename _suff input_fn output_fn 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 ] @@ -642,7 +644,7 @@ run_phase SplitAs basename _suff _input_fn _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 ] )) @@ -656,7 +658,7 @@ run_phase SplitAs basename _suff _input_fn _output_fn 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 @@ -695,7 +697,7 @@ doLink o_files = do else [] #endif (md_c_flags, _) <- machdepCCOpts - run_something "Linker" + runSomething "Linker" (unwords ([ ln, verb, "-o", output_fn ] ++ md_c_flags @@ -770,21 +772,20 @@ data CompResult 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 [] @@ -857,7 +858,7 @@ dealWithStubs basename maybe_stub_h maybe_stub_c 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 @@ -867,7 +868,7 @@ dealWithStubs basename maybe_stub_h maybe_stub_c 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, " &&", diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index b61562b..37e19e2 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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 -- @@ -116,10 +116,6 @@ v_Hs_source_cpp_opts = global ] {-# 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) @@ -731,40 +727,3 @@ machdepCCOpts | 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 () - diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 8267c93..84e6a17 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -22,7 +22,7 @@ import Bag ( Bag, bagToList, isEmptyBag ) 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 ) @@ -114,8 +114,8 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action \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 @@ -124,8 +124,8 @@ 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 "", diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 7f0ea60..34917d3 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -44,6 +44,8 @@ import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn, showPass ) import Util ( unJust ) +import Unique ( Uniquable(..) ) +import PrelNames ( ioTyConKey ) import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) @@ -56,6 +58,7 @@ import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), 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 ) @@ -416,7 +419,17 @@ hscExpr dflags hst hit pcs0 this_module expr <- 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 @@ -448,23 +461,22 @@ hscParseExpr dflags str -- 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("") 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 diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 46aec68..dbc9cec 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# 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 -- @@ -98,8 +98,8 @@ main = -- 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 @@ -201,6 +201,12 @@ main = 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" @@ -219,15 +225,16 @@ main = 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 diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 463964b..170beaa 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -23,7 +23,7 @@ import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, import TcMonad -import TcType ( newTyVarTy ) +import TcType ( newTyVarTy, zonkTcType ) import Inst ( plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) @@ -107,7 +107,7 @@ typecheckExpr :: DynFlags -> 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 $ @@ -121,7 +121,8 @@ typecheckExpr dflags pcs hst unqual this_mod (expr, decls) 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)