X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCore.lhs;h=0d3c544c4106a00d36759f1d9847970a0d285cf1;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=69f53939f11e2b67334edf0ae5b8e08dbdf4a6d0;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 69f5393..0d3c544 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -1,142 +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, +module SimplCore ( core2core ) where - IdEnv(..), - UnfoldingDetails, - SpecialiseData(..), - UniqFM, Unique, Bag - ) where +IMP_Ubiq(){-uitous-} +IMPORT_1_3(IO(hPutStr,stderr)) -IMPORT_Trace -import Outputable -import Pretty - -import PlainCore - -import AbsUniType ( getTyConDataCons, alpha_ty, alpha_tyvar, beta_ty, beta_tyvar ) ---SAVE:import ArityAnal ( arityAnalProgram ) -import Bag -import BinderInfo ( BinderInfo) -- instances only +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, - getIdUniType, toplevelishId, - idWantsToBeINLINEd, +import FoldrBuildWW ( mkFoldrBuildWW ) +import Id ( idType, toplevelishId, idWantsToBeINLINEd, unfoldingUnfriendlyId, isWrapperId, - mkTemplateLocals - IF_ATTACK_PRAGMAS(COMMA getIdStrictness) + nullIdEnv, addOneToIdEnv, delOneFromIdEnv, + lookupIdEnv, SYN_IE(IdEnv), + GenId{-instance Outputable-} ) -import IdEnv -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 -import SimplEnv ( UnfoldingGuidance(..), SwitchChecker(..) ) -- instances ---ANDY: ---import SimplHaskell ( coreToHaskell ) -import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount ) +import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) -import SimplVar ( leastItCouldCost ) import Specialise -import SpecTyFuns ( pprSpecErrs ) +import SpecUtils ( pprSpecErrs ) import StrictAnal ( saWwTopBinds ) -#if ! OMIT_FOLDR_BUILD -import FoldrBuildWW -import AnalFBWW -#endif +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 TyVarEnv ( nullTyVarEnv ) -import SplitUniq -import Unique -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) - -> SplitUniqSupply -- a name supply + -> UniqSupply -- a name supply -> [TyCon] -- local data tycons and tycon specialisations - -> FiniteMap TyCon [[Maybe UniType]] - -> [PlainCoreBinding] -- input... - -> MainIO - ([PlainCoreBinding], -- results: program, plus... - IdEnv UnfoldingDetails, -- unfoldings to be exported from here + -> FiniteMap TyCon [(Bool, [Maybe Type])] + -> [CoreBinding] -- input... + -> IO + ([CoreBinding], -- results: program, plus... + 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 trace ("Simplifier Stats:\n" ++ showSimplCount simpl_stats) (returnMn ()) - else returnMn () - ) `thenMn_` - -{- LATER: - (if do_dump_core_passes - then trace (unlines ( - (nOfThem 78 '-' - : "Core2Core" - : "+------------------------------+" - : reverse [ " " ++ take (30::Int) (what ++ repeat ' ') ++ "|" - | what <- simpl_whats ]) - ++ ["+------------------------------+"])) - else \x -> x) -- to the end --} - 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 = opt_D_verbose_core2core - do_dump_core_passes = switch_is_on D_dump_core_passes -- an Andy flag - do_verbose_core2core = switch_is_on D_verbose_core2core - - lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME + 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 ) @@ -147,152 +139,136 @@ 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") - case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of + -> _scc_ "CoreSimplify" + begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild + then " (foldr/build)" else "") >> + case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of (p, it_cnt, simpl_stats2) - -> end_pass us2 p inline_env spec_data simpl_stats2 ("Simplify (" ++ show it_cnt ++ ")") - ESCC + -> 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 "") CoreDoFoldrBuildWorkerWrapper -#if OMIT_FOLDR_BUILD - -> error "ERROR: CoreDoFoldrBuildWorkerWrapper: not built into compiler\n" -#else - -> BSCC("CoreDoFoldrBuildWorkerWrapper") - end_pass us2 (mkFoldrBuildWW switch_is_on us1 binds) inline_env spec_data simpl_stats "FBWW" - ESCC -#endif + -> _scc_ "CoreDoFoldrBuildWorkerWrapper" + begin_pass "FBWW" >> + case (mkFoldrBuildWW us1 binds) of { binds2 -> + end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" } CoreDoFoldrBuildWWAnal -#if OMIT_FOLDR_BUILD - -> error "ERROR: CoreDoFoldrBuildWWAnal: not built into compiler\n" -#else - -> BSCC("CoreDoFoldrBuildWWAnal") - end_pass us2 (analFBWW switch_is_on binds) inline_env spec_data simpl_stats "AnalFBWW" - ESCC -#endif + -> _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") + -> _scc_ "LiberateCase" + begin_pass "LiberateCase" >> case (liberateCase lib_case_threshold binds) of { binds2 -> - end_pass 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") - case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 -> - end_pass us2 binds inline_env2 spec_data simpl_stats "Calc Inlinings" - } 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") - case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 -> - end_pass us2 binds inline_env2 spec_data simpl_stats "Calc Inlinings" - } 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") - end_pass us2 (floatInwards binds) inline_env spec_data simpl_stats "FloatIn" - ESCC + -> _scc_ "FloatInwards" + begin_pass "FloatIn" >> + case (floatInwards binds) of { binds2 -> + end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" } CoreDoFullLaziness - -> BSCC("CoreFloating") - case (floatOutwards switch_is_on us1 binds) of { p -> - end_pass us2 p inline_env spec_data simpl_stats "FloatOut" - } ESCC - - CoreDoPrintCore -> - let - printed = ppShow 80 (ppr ppr_style binds) - strict [] a = a - strict (s:ss) a | ord s == 0 = error "0 in output string" - | otherwise = strict ss a - in - end_pass us2 (strict printed (trace ("PrintCore:\n" ++ printed) binds)) inline_env spec_data simpl_stats "Print" - -{- ANDY: - CoreDoHaskPrint -> - let - printed = coreToHaskell binds - strict [] a = a - strict (s:ss) a | ord s == 0 = error "0 in output string" - | otherwise = strict ss a - in - strict printed (trace ("PrintCore:\n" ++ printed) binds), inline_env, spec_data, simpl_stats, "PrintHask" --} + -> _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") - end_pass us2 (doStaticArgs binds us1) inline_env spec_data simpl_stats "SAT" + -> _scc_ "CoreStaticArgs" + begin_pass "StaticArgs" >> + case (doStaticArgs binds us1) of { binds2 -> + 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") - end_pass us2 (saWwTopBinds us1 switch_is_on binds) 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") - 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-} - (pprSpecErrs PprForUser spec_errs spec_warn spec_tyerrs)) - `thenMn_` writeMn stderr "\n" + (if not spec_noerrs || + (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then + hPutStr stderr (ppShow 1000 {-pprCols-} + (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs)) + >> 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 us2 p inline_env spec_data2 simpl_stats "Specialise" + end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise" } - ESCC - CoreDoDeforest + CoreDoDeforest #if OMIT_DEFORESTER -> error "ERROR: CoreDoDeforest: not built into compiler\n" #else - -> BSCC("Deforestation") - case (deforestProgram sw_chkr binds us1) of { binds -> - end_pass us2 binds 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") - end_pass us2 (addAutoCostCentres sw_chkr module_name binds) 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" ------------------------------------------------- - end_pass us2 binds2 inline_env2 + begin_pass + = 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 _ _ _ _ _ _ _) simpl_stats2 what = -- report verbosely, if required - (if do_verbose_core2core then - writeMn stderr ("\n*** "++what++":\n") - `thenMn_` - writeMn stderr (ppShow 1000 - (ppAboves (map (pprPlainCoreBinding ppr_style) binds2))) - `thenMn_` - writeMn stderr "\n" + (if (do_verbose_core2core && not print) || + (print && not do_verbose_core2core) + then + 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 @@ -301,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} @@ -327,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 - -> [PlainCoreBinding] - -> IdEnv UnfoldingDetails + -> IdEnv Unfolding + -> [CoreBinding] + -> 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 @@ -342,40 +317,38 @@ 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 (GeneralForm _ _ 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 con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT - calci inline_env (CoRec pairs) + calci inline_env (Rec pairs) = foldl (calc True{-recursive-}) inline_env pairs - calci inline_env bind@(CoNonRec binder rhs) + calci inline_env bind@(NonRec binder rhs) = calc False{-not recursive-} inline_env (binder, rhs) --------------------------------------- @@ -383,56 +356,53 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds calc is_recursive inline_env (binder, rhs) | not (toplevelishId binder) = --pprTrace "giving up on not top-level:" (ppr PprDebug binder) - ignominious_defeat + ignominious_defeat | rhs_mentions_an_unmentionable || (not explicit_INLINE_requested - && (guidance_says_don't || guidance_size_just_too_big)) + && (rhs_looks_like_a_caf || guidance_size_too_big)) = let my_my_trace = if explicit_INLINE_requested && not (isWrapperId binder) -- these always claim to be INLINEd && not have_inlining_already - then trace -- we'd better have a look... + then trace -- we'd better have a look... else my_trace 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, guidance_says_don't, guidance_size_just_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 + -- For the deforester: bypass the barbed wire for recursive -- functions that want to be inlined and are tagged deforestable -- by the user, allowing these things to be communicated -- across module boundaries. - | is_recursive && - explicit_INLINE_requested && + | is_recursive && + explicit_INLINE_requested && deforestable binder && - scc_s_OK -- hack, only get them in + scc_s_OK -- hack, only get them in -- calc_inlinings2 = glorious_success UnfoldAlways -#endif +#endif - | is_recursive && not rhs_looks_like_a_data_val_to_me + | is_recursive && not rhs_looks_like_a_data_val -- The only recursive defns we are prepared to tolerate at the -- moment is top-level very-obviously-a-data-value ones. -- We *need* these for dictionaries to be exported! = --pprTrace "giving up on rec:" (ppr PprDebug binder) ignominious_defeat - -- Not really interested unless it's exported, but doing it + -- Not really interested unless it's exported, but doing it -- this way (not worrying about export-ness) gets us all the -- workers/specs, etc., too; which we will need for generating -- interfaces. We are also not interested if this binder is @@ -454,67 +424,38 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds then 100000 -- you asked for it, you got it else unfolding_creation_threshold - guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False } - guidance_size = case guidance of UnfoldAlways -> 0 -- *extremely* small - EssentialUnfolding -> 0 -- ditto UnfoldIfGoodArgs _ _ _ size -> size - guidance_size_just_too_big + 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 - UnfoldNever -> False -- debugging only (ToDo:rm) - 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_to_me then - False -- probably a data value; we'd like the - -- other guy to see the value, even if - -- s/he doesn't unfold it. - 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_arg_tys - = let - (_, val_binders, _) = digForLambdas rhs - in - map getIdUniType val_binders - rhs_looks_like_a_data_val_to_me - = let - (_,val_binders,body) = digForLambdas rhs - in - case (val_binders, body) of - ([], CoCon _ _ _) -> True - other -> False + rhs_looks_like_a_caf = not (whnfOrBottom rhs) + + rhs_looks_like_a_data_val + = case (collectBinders rhs) of + (_, _, [], Con _ _) -> True + other -> False + + rhs_arg_tys + = 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 ... #-}? @@ -553,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 @@ -593,7 +534,7 @@ calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds ignominious_defeat -- and at the last hurdle, too! \end{code} -ANDY, on the hatred of the check above; why obliterate it? Consider +ANDY, on the hatred of the check above; why obliterate it? Consider head xs = foldr (\ x _ -> x) (_|_) xs