X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=0d3c544c4106a00d36759f1d9847970a0d285cf1;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=cf446c0564884c9f1a9fa67b9ae18c2dc96ac8b3;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index cf446c0..0d3c544 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -1,116 +1,134 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} #include "HsVersions.h" -module SimplCore ( - core2core - ) where +module SimplCore ( core2core ) where -import Type ( getTyConDataCons ) ---SAVE:import ArityAnal ( arityAnalProgram ) -import Bag -import BinderInfo ( BinderInfo) -- instances only +IMP_Ubiq(){-uitous-} +IMPORT_1_3(IO(hPutStr,stderr)) + +import AnalFBWW ( analFBWW ) +import Bag ( isEmptyBag, foldBag ) +import BinderInfo ( BinderInfo{-instance Outputable-} ) import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD, uNFOLDING_USE_THRESHOLD, uNFOLDING_OVERRIDE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT ) -import CmdLineOpts +import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn, + opt_D_show_passes, + opt_D_simplifier_stats, + opt_D_verbose_core2core, + opt_DoCoreLinting, + opt_FoldrBuildOn, + opt_ReportWhyUnfoldingsDisallowed, + opt_ShowImportSpecs, + opt_UnfoldingCreationThreshold, + opt_UnfoldingOverrideThreshold, + opt_UnfoldingUseThreshold + ) import CoreLint ( lintCoreBindings ) +import CoreSyn +import CoreUnfold +import CoreUtils ( substCoreBindings ) +import ErrUtils ( ghcExit ) +import FiniteMap ( FiniteMap ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( getIdUnfolding, - idType, toplevelishId, - idWantsToBeINLINEd, +import FoldrBuildWW ( mkFoldrBuildWW ) +import Id ( idType, toplevelishId, idWantsToBeINLINEd, unfoldingUnfriendlyId, isWrapperId, - mkTemplateLocals + nullIdEnv, addOneToIdEnv, delOneFromIdEnv, + lookupIdEnv, SYN_IE(IdEnv), + GenId{-instance Outputable-} ) -import IdInfo +import IdInfo ( mkUnfolding ) import LiberateCase ( liberateCase ) -import MainMonad -import Maybes +import MagicUFs ( MagicUnfoldingFun ) +import Maybes ( maybeToBool ) +import Outputable ( Outputable(..){-instance * (,) -} ) +import PprCore +import PprStyle ( PprStyle(..) ) +import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) +import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr ) import SAT ( doStaticArgs ) -import SCCauto ---ANDY: ---import SimplHaskell ( coreToHaskell ) -import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount ) +import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) -import SimplVar ( leastItCouldCost ) import Specialise import SpecUtils ( pprSpecErrs ) import StrictAnal ( saWwTopBinds ) -import FoldrBuildWW -import AnalFBWW +import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instance Eq-} ) +import UniqSupply ( splitUniqSupply ) +import Util ( panic{-ToDo:rm-} ) + #if ! OMIT_DEFORESTER import Deforest ( deforestProgram ) import DefUtils ( deforestable ) #endif -import UniqSupply -import Util + +isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)" \end{code} \begin{code} core2core :: [CoreToDo] -- spec of what core-to-core passes to do - -> (GlobalSwitch->SwitchResult)-- "global" command-line info lookup fn -> 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])] -> [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 sw_chkr module_name ppr_style us local_tycons tycon_specs binds - = BSCC("Core2Core") - if null core_todos then -- very rare, I suspect... +core2core core_todos module_name ppr_style us local_tycons tycon_specs binds + = if null core_todos then -- very rare, I suspect... -- well, we still must do some renumbering - returnMn ( - (snd (instCoreBindings (mkUniqueSupplyGrimily us) binds), nullIdEnv, init_specdata) + 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) -> - - (if switch_is_on 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 + >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> + + (if opt_D_simplifier_stats + 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 - switch_is_on = switchIsOn sw_chkr - - do_verbose_core2core = switch_is_on D_verbose_core2core + do_verbose_core2core = opt_D_verbose_core2core lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME -- Use 4x a known threshold - = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of + = case opt_UnfoldingOverrideThreshold of Nothing -> 4 * uNFOLDING_USE_THRESHOLD Just xx -> 4 * xx ------------- - core_linter = if switch_is_on DoCoreLinting + core_linter = if opt_DoCoreLinting then lintCoreBindings ppr_style else ( \ whodunnit spec_done binds -> binds ) @@ -121,138 +139,116 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b 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_` - case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of + 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_` - case (mkFoldrBuildWW switch_is_on us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" - } ESCC + -> _scc_ "CoreDoFoldrBuildWorkerWrapper" + begin_pass "FBWW" >> + case (mkFoldrBuildWW us1 binds) of { binds2 -> + end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" } CoreDoFoldrBuildWWAnal - -> BSCC("CoreDoFoldrBuildWWAnal") - begin_pass "AnalFBWW" `thenMn_` - case (analFBWW switch_is_on binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" - } ESCC + -> _scc_ "CoreDoFoldrBuildWWAnal" + begin_pass "AnalFBWW" >> + case (analFBWW binds) of { binds2 -> + 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_` - case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 -> - end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" - } ESCC + -> _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" } CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres - -> BSCC("CoreInlinings2") - begin_pass "CalcInlinings" `thenMn_` - case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 -> - end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" - } ESCC + -> _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" } 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_` - case (floatOutwards switch_is_on us1 binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" - } ESCC + -> _scc_ "CoreFloating" + begin_pass "FloatOut" >> + case (floatOutwards us1 binds) of { binds2 -> + 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_` - case (saWwTopBinds us1 switch_is_on binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" - } ESCC + -> _scc_ "CoreStranal" + begin_pass "StrAnal" >> + case (saWwTopBinds us1 binds) of { binds2 -> + end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" } CoreDoSpecialising - -> BSCC("Specialise") - begin_pass "Specialise" `thenMn_` - case (specProgram switch_is_on us1 binds spec_data) of { + -> _scc_ "Specialise" + begin_pass "Specialise" >> + case (specProgram us1 binds spec_data) of { (p, spec_data2@(SpecData _ spec_noerrs _ _ _ spec_errs spec_warn spec_tyerrs)) -> -- if we got errors, we die straight away (if not spec_noerrs || - (switch_is_on ShowImportSpecs && not (isEmptyBag spec_warn)) then - writeMn stderr (ppShow 1000 {-pprCols-} + (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then + 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_` - case (deforestProgram sw_chkr binds us1) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" - } - ESCC + -> _scc_ "Deforestation" + begin_pass "Deforestation" >> + case (deforestProgram binds us1) of { binds2 -> + end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" } #endif - CoreDoAutoCostCentres - -> BSCC("AutoSCCs") - begin_pass "AutoSCCs" `thenMn_` - case (addAutoCostCentres sw_chkr 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 switch_is_on D_show_passes - then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n") - else \ what -> returnMn () + = if opt_D_show_passes + then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n") + else \ what -> return () end_pass print us2 binds2 inline_env2 spec_data2@(SpecData spec_done _ _ _ _ _ _ _) @@ -261,18 +257,18 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b (if (do_verbose_core2core && not print) || (print && not do_verbose_core2core) then - writeMn stderr ("\n*** "++what++":\n") - `thenMn_` - writeMn stderr (ppShow 1000 - (ppAboves (map (pprPlainCoreBinding ppr_style) binds2))) - `thenMn_` - writeMn stderr "\n" + hPutStr stderr ("\n*** "++what++":\n") + >> + hPutStr stderr (ppShow 1000 + (ppAboves (map (pprCoreBinding ppr_style) binds2))) + >> + 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 @@ -281,8 +277,8 @@ core2core core_todos sw_chkr module_name ppr_style us local_tycons tycon_specs b ) -- 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} @@ -307,12 +303,11 @@ will be visible on the other side of an interface, too. \begin{code} calcInlinings :: Bool -- True => inlinings with _scc_s are OK - -> (GlobalSwitch -> SwitchResult) - -> IdEnv UnfoldingDetails + -> IdEnv Unfolding -> [CoreBinding] - -> IdEnv UnfoldingDetails + -> IdEnv Unfolding -calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds +calcInlinings scc_s_OK inline_env_so_far top_binds = let result = foldl calci inline_env_so_far top_binds in @@ -322,31 +317,29 @@ calcInlinings scc_s_OK sw_chkr 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 (IWantToBeINLINEd _) = ppStr "INLINE" - pp_det (GenForm _ _ expr guide) + pp_det NoUnfolding = ppStr "_N_" +--LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE" + pp_det (CoreUnfolding (SimpleUnfolding _ guide expr)) = ppAbove (ppr PprDebug guide) (ppr PprDebug expr) pp_det other = ppStr "???" ------------ - switch_is_on = switchIsOn sw_chkr - - my_trace = if (switch_is_on ReportWhyUnfoldingsDisallowed) + my_trace = if opt_ReportWhyUnfoldingsDisallowed then trace else \ msg stuff -> stuff (unfolding_creation_threshold, explicit_creation_threshold) - = case (intSwitchSet sw_chkr UnfoldingCreationThreshold) of + = case opt_UnfoldingCreationThreshold of Nothing -> (uNFOLDING_CREATION_THRESHOLD, False) Just xx -> (xx, True) unfold_use_threshold - = case (intSwitchSet sw_chkr UnfoldingUseThreshold) of + = case opt_UnfoldingUseThreshold of Nothing -> uNFOLDING_USE_THRESHOLD Just xx -> xx unfold_override_threshold - = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of + = case opt_UnfoldingOverrideThreshold of Nothing -> uNFOLDING_OVERRIDE_THRESHOLD Just xx -> xx @@ -367,7 +360,7 @@ calcInlinings scc_s_OK sw_chkr 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 @@ -378,20 +371,15 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds which = if scc_s_OK then " (late):" else " (early):" in - --pprTrace "giving up on size:" (ppCat [ppr PprDebug binder, ppr PprDebug - -- [rhs_mentions_an_unmentionable, explicit_INLINE_requested, - -- rhs_looks_like_a_caf, guidance_says_don't, guidance_size_too_big]]) ( my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) ( ignominious_defeat ) - --) | rhs `isWrapperFor` binder -- Don't add an explicit "unfolding"; let the worker/wrapper -- stuff do its thing. INLINE things don't get w/w'd, so -- they will be OK. - = --pprTrace "giving up on isWrapperFor:" (ppr PprDebug binder) - ignominious_defeat + = ignominious_defeat #if ! OMIT_DEFORESTER -- For the deforester: bypass the barbed wire for recursive @@ -439,59 +427,35 @@ calcInlinings scc_s_OK sw_chkr 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 (digForLambdas rhs) of - (_, _, [], Con _ _ _) -> True - other -> False + = case (collectBinders rhs) of + (_, _, [], Con _ _) -> True + other -> False rhs_arg_tys - = case (digForLambdas rhs) of + = case (collectBinders rhs) of (_, _, val_binders, _) -> map idType val_binders (mentioned_ids, _, _, mentions_litlit) = mentionedInUnfolding (\x -> x) rhs rhs_mentions_an_unmentionable - = --pprTrace "mentions:" (ppCat [ppr PprDebug binder, ppr PprDebug [(i,unfoldingUnfriendlyId i) | i <- mentioned_ids ]]) ( - any unfoldingUnfriendlyId mentioned_ids + = foldBag (||) unfoldingUnfriendlyId False mentioned_ids || mentions_litlit - --) -- ToDo: probably need to chk tycons/classes... - mentions_no_other_ids = null mentioned_ids + mentions_no_other_ids = isEmptyBag mentioned_ids explicit_INLINE_requested -- did it come from a user {-# INLINE ... #-}? @@ -530,7 +494,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds = let new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs) - foldr_building = switch_is_on FoldrBuildOn + foldr_building = opt_FoldrBuildOn in if (not have_inlining_already) then -- Not in env: we take it no matter what