From: sof Date: Thu, 4 Sep 1997 20:05:55 +0000 (+0000) Subject: [project @ 1997-09-04 20:05:55 by sof] X-Git-Tag: Approximately_1000_patches_recorded~18 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=44616f4e4c5dd73be8af71568a321f52b5f6f745 [project @ 1997-09-04 20:05:55 by sof] tidy up; bug fix for poly-case --- diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index e6bf0e1..70520e3 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -17,6 +17,7 @@ import BinderInfo ( BinderInfo{-instance Outputable-} ) import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, opt_D_show_passes, opt_D_simplifier_stats, + opt_D_dump_simpl, opt_D_verbose_core2core, opt_DoCoreLinting, opt_FoldrBuildOn, @@ -30,7 +31,7 @@ import CoreUtils ( coreExprType ) import SimplUtils ( etaCoreExpr, typeOkForCase ) import CoreUnfold import Literal ( Literal(..), literalType, mkMachInt ) -import ErrUtils ( ghcExit ) +import ErrUtils ( ghcExit, dumpIfSet, doIfSet ) import FiniteMap ( FiniteMap ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) @@ -58,7 +59,9 @@ import Type ( maybeAppDataTyCon, isPrimType, SYN_IE(Type) ) import TysWiredIn ( stringTy, isIntegerTy ) import LiberateCase ( liberateCase ) import MagicUFs ( MagicUnfoldingFun ) -import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} ) +import Outputable ( pprDumpStyle, printErrs, + PprStyle(..), Outputable(..){-instance * (,) -} + ) import PprCore import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-}, nmbrType @@ -100,7 +103,6 @@ import DefUtils ( deforestable ) \begin{code} core2core :: [CoreToDo] -- spec of what core-to-core passes to do -> FAST_STRING -- module name (profiling only) - -> PprStyle -- printing style (for debugging only) -> UniqSupply -- a name supply -> [TyCon] -- local data tycons and tycon specialisations -> FiniteMap TyCon [(Bool, [Maybe Type])] @@ -109,13 +111,8 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do ([CoreBinding], -- results: program, plus... SpecialiseData) -- specialisation data -core2core core_todos module_name ppr_style us local_tycons tycon_specs binds - = -- Print heading - (if opt_D_verbose_core2core then - hPutStr stderr "VERBOSE CORE-TO-CORE:\n" - else return ()) >> - - -- Do the main business +core2core core_todos module_name us local_tycons tycon_specs binds + = -- Do the main business foldl_mn do_core_pass (binds, us, init_specdata, zeroSimplCount) core_todos @@ -123,32 +120,27 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -- Do the final tidy-up let - final_binds = core_linter "TidyCorePgm" True $ - tidyCorePgm module_name processed_binds + final_binds = tidyCorePgm module_name processed_binds in + lintCoreBindings "TidyCorePgm" True final_binds >> + + + -- Dump output + dumpIfSet (opt_D_dump_simpl || opt_D_verbose_core2core) + "Core transformations" + (pprCoreBindings pprDumpStyle final_binds) >> -- Report statistics - (if opt_D_simplifier_stats then - hPutStr stderr ("\nSimplifier Stats:\n") >> - hPutStr stderr (showSimplCount simpl_stats) >> - hPutStr stderr "\n" - else return ()) >> + doIfSet opt_D_simplifier_stats + (hPutStr stderr ("\nSimplifier Stats:\n") >> + hPutStr stderr (showSimplCount simpl_stats) >> + hPutStr stderr "\n") >> - -- + -- Return results return (final_binds, spec_data) where init_specdata = initSpecData local_tycons tycon_specs - ------------- - core_linter what spec_done - = if opt_DoCoreLinting - then (if opt_D_show_passes then - trace ("\n*** Core Lint result of " ++ what) - else id - ) - lintCoreBindings ppr_style what spec_done - else id - -------------- do_core_pass info@(binds, us, spec_data, simpl_stats) to_do = case (splitUniqSupply us) of @@ -160,7 +152,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds then " (foldr/build)" else "") >> case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of (p, it_cnt, simpl_stats2) - -> end_pass False us2 p spec_data simpl_stats2 + -> end_pass us2 p spec_data simpl_stats2 ("Simplify (" ++ show it_cnt ++ ")" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild then " foldr/build" else "") @@ -169,37 +161,37 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "CoreDoFoldrBuildWorkerWrapper" begin_pass "FBWW" >> case (mkFoldrBuildWW us1 binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "FBWW" } + end_pass us2 binds2 spec_data simpl_stats "FBWW" } CoreDoFoldrBuildWWAnal -> _scc_ "CoreDoFoldrBuildWWAnal" begin_pass "AnalFBWW" >> case (analFBWW binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" } + end_pass us2 binds2 spec_data simpl_stats "AnalFBWW" } CoreLiberateCase -> _scc_ "LiberateCase" begin_pass "LiberateCase" >> case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" } + end_pass us2 binds2 spec_data simpl_stats "LiberateCase" } CoreDoFloatInwards -> _scc_ "FloatInwards" begin_pass "FloatIn" >> case (floatInwards binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "FloatIn" } + end_pass us2 binds2 spec_data simpl_stats "FloatIn" } CoreDoFullLaziness -> _scc_ "CoreFloating" begin_pass "FloatOut" >> case (floatOutwards us1 binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "FloatOut" } + end_pass us2 binds2 spec_data simpl_stats "FloatOut" } CoreDoStaticArgs -> _scc_ "CoreStaticArgs" begin_pass "StaticArgs" >> case (doStaticArgs binds us1) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" } + end_pass us2 binds2 spec_data simpl_stats "StaticArgs" } -- Binds really should be dependency-analysed for static- -- arg transformation... Not to worry, they probably are. -- (I don't think it *dies* if they aren't [WDP 94/04/15]) @@ -208,7 +200,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "CoreStranal" begin_pass "StrAnal" >> case (saWwTopBinds us1 binds) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "StrAnal" } + end_pass us2 binds2 spec_data simpl_stats "StrAnal" } CoreDoSpecialising -> _scc_ "Specialise" @@ -218,20 +210,16 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds spec_errs spec_warn spec_tyerrs)) -> -- if we got errors, we die straight away - (if not spec_noerrs || - (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then - hPutStr stderr (show + doIfSet ((not spec_noerrs) || + (opt_ShowImportSpecs && not (isEmptyBag spec_warn))) + (printErrs (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs)) - >> hPutStr stderr "\n" - else - return ()) >> + >> - (if not spec_noerrs then -- Stop here if specialisation errors occured - ghcExit 1 - else - return ()) >> + doIfSet (not spec_noerrs) -- Stop here if specialisation errors occured + (ghcExit 1) >> - end_pass False us2 p spec_data2 simpl_stats "Specialise" + end_pass us2 p spec_data2 simpl_stats "Specialise" } CoreDoDeforest @@ -241,43 +229,37 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> _scc_ "Deforestation" begin_pass "Deforestation" >> case (deforestProgram binds us1) of { binds2 -> - end_pass False us2 binds2 spec_data simpl_stats "Deforestation" } + end_pass us2 binds2 spec_data simpl_stats "Deforestation" } #endif CoreDoPrintCore -- print result of last pass - -> end_pass True us2 binds spec_data simpl_stats "Print" + -> dumpIfSet (not opt_D_verbose_core2core) "Print Core" + (pprCoreBindings pprDumpStyle binds) >> + return (binds, us1, spec_data, simpl_stats) ------------------------------------------------- - begin_pass + begin_pass what = if opt_D_show_passes - then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n") - else \ what -> return () + then hPutStr stderr ("*** Core2Core: "++what++"\n") + else return () - end_pass print us2 binds2 + end_pass us2 binds2 spec_data2@(SpecData spec_done _ _ _ _ _ _ _) simpl_stats2 what - = -- report verbosely, if required - (if (opt_D_verbose_core2core && not print) || - (print && not opt_D_verbose_core2core) - then - hPutStr stderr ("\n*** "++what++":\n") - >> - hPutStr stderr (show - (vcat (map (pprCoreBinding ppr_style) binds2))) - >> - hPutStr stderr "\n" - else - return ()) >> - let - linted_binds = core_linter what spec_done binds2 - in + = -- Report verbosely, if required + dumpIfSet opt_D_verbose_core2core what + (pprCoreBindings pprDumpStyle binds2) >> + + lintCoreBindings what spec_done binds2 >> + return - (linted_binds, -- processed binds, possibly run thru CoreLint - us2, -- UniqSupply for the next guy - spec_data2, -- possibly-updated specialisation info - simpl_stats2 -- accumulated simplifier stats - ) + (binds2, -- processed binds, possibly run thru CoreLint + us2, -- UniqSupply for the next guy + spec_data2, -- possibly-updated specialisation info + simpl_stats2 -- accumulated simplifier stats + ) + -- here so it can be inlined... foldl_mn f z [] = return z @@ -564,7 +546,8 @@ tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs))) | not (typeOkForCase (idType deflt_bndr)) = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $ case scrut of - Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs) + Var v -> lookupId v `thenTM` \ v' -> + extendEnvTM deflt_bndr v' (tidyCoreExpr rhs) other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs) tidyCoreExpr (Case scrut alts)