X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplVar.lhs;h=98a89578a9e473b24df49ec4b00680c39c8ebcf7;hb=d68e10d903cab0f572d9f6397d112bb01a6f919f;hp=80951af6db693f3cb068c8d97e15859fef04031b;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 80951af..98a8957 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -11,34 +11,38 @@ module SimplVar ( ) where IMP_Ubiq(){-uitous-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 IMPORT_DELOOPER(SmplLoop) ( simplExpr ) +#else +import {-# SOURCE #-} Simplify ( simplExpr ) +#endif import Constants ( uNFOLDING_USE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT ) import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..), SimpleUnfolding(..), - FormSummary, - okToInline, smallEnoughToInline ) -import BinderInfo ( BinderInfo, noBinderInfo ) +import CoreUnfold ( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..), + SimpleUnfolding(..), + FormSummary, whnfOrBottom, + smallEnoughToInline ) +import BinderInfo ( BinderInfo, noBinderInfo, okToInline ) -import CostCentre ( CostCentre, noCostCentreAttached ) +import CostCentre ( CostCentre, isCurrentCostCentre ) import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation, idMustBeINLINEd, GenId{-instance Outputable-} ) import SpecEnv ( SpecEnv, lookupSpecEnv ) -import IdInfo ( DeforestInfo(..) ) import Literal ( isNoRepLit ) import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) -import PprStyle ( PprStyle(..) ) +import Outputable ( Outputable(..), PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppBesides, ppStr ) import SimplEnv import SimplMonad import TyCon ( tyConFamilySize ) import Util ( pprTrace, assertPanic, panic ) import Maybes ( maybeToBool ) +import Pretty \end{code} %************************************************************************ @@ -50,37 +54,46 @@ import Maybes ( maybeToBool ) This where all the heavy-duty unfolding stuff comes into its own. \begin{code} -completeVar env var args +completeVar env var args result_ty | maybeToBool maybe_magic_result = tick MagicUnfold `thenSmpl_` magic_result - | not do_deforest && - maybeToBool maybe_unfolding_info && - (not essential_unfoldings_only || idMustBeINLINEd var) && - ok_to_inline && - -- If "essential_unfolds_only" is true we do no inlinings at all, + -- If there's an InUnfolding it means that there's no + -- let-binding left for the thing, so we'd better inline it! + | must_unfold + = let + Just (_, _, InUnfolding rhs_env rhs) = info_from_env + in + unfold var rhs_env rhs args result_ty + + + -- Conditional unfolding. There's a binding for the + -- thing, but perhaps we want to inline it anyway + | ( maybeToBool maybe_unfolding_info + && (not essential_unfoldings_only || idMustBeINLINEd var) + -- If "essential_unfoldings_only" is true we do no inlinings at all, -- EXCEPT for things that absolutely have to be done -- (see comments with idMustBeINLINEd) - -- - -- Need to be careful: the RHS of INLINE functions is protected against inlining - -- by essential_unfoldings_only being set true; we must not inline workers back into - -- wrappers, even thouth the former have an unfold-always guidance. - costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env) - = tick UnfoldingDone `thenSmpl_` - simplExpr unfold_env unf_template args + && ok_to_inline + && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env) + ) + = unfold var unf_env unf_template args result_ty + | maybeToBool maybe_specialisation = tick SpecialisationDone `thenSmpl_` simplExpr (extendTyEnvList env spec_bindings) spec_template (map TyArg leftover_ty_args ++ remaining_args) + result_ty | otherwise = returnSmpl (mkGenApp (Var var) args) where + info_from_env = lookupOutIdEnv env var unfolding_from_id = getIdUnfolding var ---------- Magic unfolding stuff @@ -91,21 +104,25 @@ completeVar env var args (Just magic_result) = maybe_magic_result ---------- Unfolding stuff + must_unfold = case info_from_env of + Just (_, _, InUnfolding _ _) -> True + other -> False + maybe_unfolding_info - = case (lookupOutIdEnv env var, unfolding_from_id) of + = case (info_from_env, unfolding_from_id) of + (Just (_, occ_info, OutUnfolding enc_cc unf), _) -> Just (occ_info, setEnclosingCC env enc_cc, unf) - (Just (_, occ_info, InUnfolding env_unf unf), _) - -> Just (occ_info, combineSimplEnv env env_unf, unf) + (_, CoreUnfolding unf) -> Just (noBinderInfo, env, unf) other -> Nothing - Just (occ_info, unfold_env, simple_unfolding) = maybe_unfolding_info + Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info SimpleUnfolding form guidance unf_template = simple_unfolding - ---------- Specialisation stuff + ---------- Specialisation stuff (ty_args, remaining_args) = initialTyArgs args maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args (Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation @@ -114,21 +131,31 @@ completeVar env var args ---------- Switches sw_chkr = getSwitchChecker env essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly - always_inline = case guidance of {UnfoldAlways -> True; other -> False} - ok_to_inline = okToInline form - occ_info - small_enough - small_enough = smallEnoughToInline arg_evals guidance - arg_evals = [is_evald arg | arg <- args, isValArg arg] - + is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee + ok_to_inline = okToInline (whnfOrBottom form) small_enough occ_info + small_enough = smallEnoughToInline arg_evals is_case_scrutinee guidance + arg_evals = [is_evald arg | arg <- args, isValArg arg] + is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v) is_evald (LitArg l) = True -#if OMIT_DEFORESTER - do_deforest = False -#else - do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False } -#endif + +-- Perform the unfolding +unfold var unf_env unf_template args result_ty + = +{- + simplCount `thenSmpl` \ n -> + (if n > 1000 then + pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr PprDebug var]) + else + id + ) + (if n>4000 then + returnSmpl (mkGenApp (Var var) args) + else +-} + tickUnfold var `thenSmpl_` + simplExpr unf_env unf_template args result_ty -- costCentreOk checks that it's ok to inline this thing @@ -137,10 +164,10 @@ completeVar env var args -- f x = let y = E in -- scc "foo" (...y...) -- --- Here y has a subsumed cost centre, and we can't inline it inside "foo", +-- Here y has a "current cost centre", and we can't inline it inside "foo", -- regardless of whether E is a WHNF or not. costCentreOk cc_encl cc_rhs - = noCostCentreAttached cc_encl || not (noCostCentreAttached cc_rhs) + = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs) \end{code}