X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=0d3c544c4106a00d36759f1d9847970a0d285cf1;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=1c99c714a2016c3c2134fed9b3d86cd0bc7a1c77;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1c99c71..0d3c544 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -8,7 +8,8 @@ module SimplCore ( core2core ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(IO(hPutStr,stderr)) import AnalFBWW ( analFBWW ) import Bag ( isEmptyBag, foldBag ) @@ -33,33 +34,30 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, import CoreLint ( lintCoreBindings ) import CoreSyn import CoreUnfold -import CoreUtils ( substCoreBindings, manifestlyWHNF ) +import CoreUtils ( substCoreBindings ) +import ErrUtils ( ghcExit ) +import FiniteMap ( FiniteMap ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FoldrBuildWW ( mkFoldrBuildWW ) import Id ( idType, toplevelishId, idWantsToBeINLINEd, - unfoldingUnfriendlyId, + unfoldingUnfriendlyId, isWrapperId, nullIdEnv, addOneToIdEnv, delOneFromIdEnv, - lookupIdEnv, IdEnv(..), + lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Outputable-} ) import IdInfo ( mkUnfolding ) import LiberateCase ( liberateCase ) import MagicUFs ( MagicUnfoldingFun ) -import MainMonad ( writeMn, exitMn, thenMn, thenMn_, returnMn, - MainIO(..) - ) import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instance * (,) -} ) -import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} ) +import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr ) import SAT ( doStaticArgs ) -import SCCauto ( addAutoCostCentres ) import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) -import SimplVar ( leastItCouldCost ) import Specialise import SpecUtils ( pprSpecErrs ) import StrictAnal ( saWwTopBinds ) @@ -74,7 +72,6 @@ import DefUtils ( deforestable ) #endif isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)" -isWrapperId = panic "SimplCore.isWrapperId (ToDo)" \end{code} \begin{code} @@ -85,42 +82,40 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do -> [TyCon] -- local data tycons and tycon specialisations -> FiniteMap TyCon [(Bool, [Maybe Type])] -> [CoreBinding] -- input... - -> MainIO + -> IO ([CoreBinding], -- results: program, plus... - IdEnv UnfoldingDetails, -- unfoldings to be exported from here + IdEnv Unfolding, -- unfoldings to be exported from here SpecialiseData) -- specialisation data core2core core_todos module_name ppr_style us local_tycons tycon_specs binds - = BSCC("Core2Core") - if null core_todos then -- very rare, I suspect... + = if null core_todos then -- very rare, I suspect... -- well, we still must do some renumbering - returnMn ( + return ( (substCoreBindings nullIdEnv nullTyVarEnv binds us, nullIdEnv, init_specdata) ) else (if do_verbose_core2core then - writeMn stderr "VERBOSE CORE-TO-CORE:\n" - else returnMn ()) `thenMn_` + hPutStr stderr "VERBOSE CORE-TO-CORE:\n" + else return ()) >> -- better do the main business foldl_mn do_core_pass (binds, us, nullIdEnv, init_specdata, zeroSimplCount) core_todos - `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> + >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> (if opt_D_simplifier_stats - then writeMn stderr ("\nSimplifier Stats:\n") - `thenMn_` - writeMn stderr (showSimplCount simpl_stats) - `thenMn_` - writeMn stderr "\n" - else returnMn () - ) `thenMn_` - - returnMn (processed_binds, inline_env, spec_data) - ESCC + then hPutStr stderr ("\nSimplifier Stats:\n") + >> + hPutStr stderr (showSimplCount simpl_stats) + >> + hPutStr stderr "\n" + else return () + ) >> + + return (processed_binds, inline_env, spec_data) where init_specdata = initSpecData local_tycons tycon_specs @@ -144,86 +139,76 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds in case to_do of CoreDoSimplify simpl_sw_chkr - -> BSCC("CoreSimplify") + -> _scc_ "CoreSimplify" begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild - then " (foldr/build)" else "") `thenMn_` + then " (foldr/build)" else "") >> case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of (p, it_cnt, simpl_stats2) -> end_pass False us2 p inline_env spec_data simpl_stats2 ("Simplify (" ++ show it_cnt ++ ")" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild then " foldr/build" else "") - ESCC CoreDoFoldrBuildWorkerWrapper - -> BSCC("CoreDoFoldrBuildWorkerWrapper") - begin_pass "FBWW" `thenMn_` + -> _scc_ "CoreDoFoldrBuildWorkerWrapper" + begin_pass "FBWW" >> case (mkFoldrBuildWW us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" - } ESCC + end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" } CoreDoFoldrBuildWWAnal - -> BSCC("CoreDoFoldrBuildWWAnal") - begin_pass "AnalFBWW" `thenMn_` + -> _scc_ "CoreDoFoldrBuildWWAnal" + begin_pass "AnalFBWW" >> case (analFBWW binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" - } ESCC + end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" } CoreLiberateCase - -> BSCC("LiberateCase") - begin_pass "LiberateCase" `thenMn_` + -> _scc_ "LiberateCase" + begin_pass "LiberateCase" >> case (liberateCase lib_case_threshold binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" - } ESCC + end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" } CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres - -> BSCC("CoreInlinings1") - begin_pass "CalcInlinings" `thenMn_` + -> _scc_ "CoreInlinings1" + begin_pass "CalcInlinings" >> case (calcInlinings False inline_env binds) of { inline_env2 -> - end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" - } ESCC + end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres - -> BSCC("CoreInlinings2") - begin_pass "CalcInlinings" `thenMn_` + -> _scc_ "CoreInlinings2" + begin_pass "CalcInlinings" >> case (calcInlinings True inline_env binds) of { inline_env2 -> - end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" - } ESCC + end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } CoreDoFloatInwards - -> BSCC("FloatInwards") - begin_pass "FloatIn" `thenMn_` + -> _scc_ "FloatInwards" + begin_pass "FloatIn" >> case (floatInwards binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" - } ESCC + end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" } CoreDoFullLaziness - -> BSCC("CoreFloating") - begin_pass "FloatOut" `thenMn_` + -> _scc_ "CoreFloating" + begin_pass "FloatOut" >> case (floatOutwards us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" - } ESCC + end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" } CoreDoStaticArgs - -> BSCC("CoreStaticArgs") - begin_pass "StaticArgs" `thenMn_` + -> _scc_ "CoreStaticArgs" + begin_pass "StaticArgs" >> case (doStaticArgs binds us1) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" + end_pass False us2 binds2 inline_env 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]) - } ESCC CoreDoStrictness - -> BSCC("CoreStranal") - begin_pass "StrAnal" `thenMn_` + -> _scc_ "CoreStranal" + begin_pass "StrAnal" >> case (saWwTopBinds us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" - } ESCC + end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" } CoreDoSpecialising - -> BSCC("Specialise") - begin_pass "Specialise" `thenMn_` + -> _scc_ "Specialise" + begin_pass "Specialise" >> case (specProgram us1 binds spec_data) of { (p, spec_data2@(SpecData _ spec_noerrs _ _ _ spec_errs spec_warn spec_tyerrs)) -> @@ -231,51 +216,39 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -- if we got errors, we die straight away (if not spec_noerrs || (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then - writeMn stderr (ppShow 1000 {-pprCols-} + hPutStr stderr (ppShow 1000 {-pprCols-} (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs)) - `thenMn_` writeMn stderr "\n" + >> hPutStr stderr "\n" else - returnMn ()) `thenMn_` + return ()) >> (if not spec_noerrs then -- Stop here if specialisation errors occured - exitMn 1 + ghcExit 1 else - returnMn ()) `thenMn_` + return ()) >> end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise" } - ESCC CoreDoDeforest #if OMIT_DEFORESTER -> error "ERROR: CoreDoDeforest: not built into compiler\n" #else - -> BSCC("Deforestation") - begin_pass "Deforestation" `thenMn_` + -> _scc_ "Deforestation" + begin_pass "Deforestation" >> case (deforestProgram binds us1) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" - } - ESCC + end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" } #endif - CoreDoAutoCostCentres - -> BSCC("AutoSCCs") - begin_pass "AutoSCCs" `thenMn_` - case (addAutoCostCentres module_name binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs" - } - ESCC - CoreDoPrintCore -- print result of last pass -> end_pass True us2 binds inline_env spec_data simpl_stats "Print" - ------------------------------------------------- begin_pass = if opt_D_show_passes - then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n") - else \ what -> returnMn () + then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n") + else \ what -> return () end_pass print us2 binds2 inline_env2 spec_data2@(SpecData spec_done _ _ _ _ _ _ _) @@ -284,18 +257,18 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds (if (do_verbose_core2core && not print) || (print && not do_verbose_core2core) then - writeMn stderr ("\n*** "++what++":\n") - `thenMn_` - writeMn stderr (ppShow 1000 + hPutStr stderr ("\n*** "++what++":\n") + >> + hPutStr stderr (ppShow 1000 (ppAboves (map (pprCoreBinding ppr_style) binds2))) - `thenMn_` - writeMn stderr "\n" + >> + hPutStr stderr "\n" else - returnMn ()) `thenMn_` + return ()) >> let linted_binds = core_linter what spec_done binds2 in - returnMn + return (linted_binds, -- processed binds, possibly run thru CoreLint us2, -- UniqueSupply for the next guy inline_env2, -- possibly-updated inline env @@ -304,8 +277,8 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds ) -- here so it can be inlined... -foldl_mn f z [] = returnMn z -foldl_mn f z (x:xs) = f z x `thenMn` \ zz -> +foldl_mn f z [] = return z +foldl_mn f z (x:xs) = f z x >>= \ zz -> foldl_mn f zz xs \end{code} @@ -330,9 +303,9 @@ will be visible on the other side of an interface, too. \begin{code} calcInlinings :: Bool -- True => inlinings with _scc_s are OK - -> IdEnv UnfoldingDetails + -> IdEnv Unfolding -> [CoreBinding] - -> IdEnv UnfoldingDetails + -> IdEnv Unfolding calcInlinings scc_s_OK inline_env_so_far top_binds = let @@ -344,9 +317,9 @@ calcInlinings scc_s_OK inline_env_so_far top_binds pp_item (binder, details) = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details] where - pp_det NoUnfoldingDetails = ppStr "_N_" + pp_det NoUnfolding = ppStr "_N_" --LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE" - pp_det (GenForm _ _ expr guide) + pp_det (CoreUnfolding (SimpleUnfolding _ guide expr)) = ppAbove (ppr PprDebug guide) (ppr PprDebug expr) pp_det other = ppStr "???" @@ -387,7 +360,7 @@ calcInlinings scc_s_OK inline_env_so_far top_binds | rhs_mentions_an_unmentionable || (not explicit_INLINE_requested - && (rhs_looks_like_a_caf || guidance_says_don't || guidance_size_too_big)) + && (rhs_looks_like_a_caf || guidance_size_too_big)) = let my_my_trace = if explicit_INLINE_requested @@ -454,38 +427,16 @@ calcInlinings scc_s_OK inline_env_so_far top_binds guidance_size = case guidance of UnfoldAlways -> 0 -- *extremely* small - EssentialUnfolding -> 0 -- ditto UnfoldIfGoodArgs _ _ _ size -> size - guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False } - guidance_size_too_big -- Does the guidance suggest that this unfolding will -- be of no use *no matter* the arguments given to it? -- Could be more sophisticated... - = case guidance of - UnfoldAlways -> False - EssentialUnfolding -> False - UnfoldIfGoodArgs _ no_val_args arg_info_vec size - - -> if explicit_creation_threshold then - False -- user set threshold; don't second-guess... - - else if no_val_args == 0 && rhs_looks_like_a_data_val then - False -- we'd like a top-level data constr to be - -- visible even if it is never unfolded - else - let - cost - = leastItCouldCost con_discount_weight size no_val_args - arg_info_vec rhs_arg_tys - in --- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) ( - unfold_use_threshold < cost --- ) + = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance) - rhs_looks_like_a_caf = not (manifestlyWHNF rhs) + rhs_looks_like_a_caf = not (whnfOrBottom rhs) rhs_looks_like_a_data_val = case (collectBinders rhs) of