) 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}
%************************************************************************
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
(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
---------- 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
-- 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}
projects / ghc-hetmet.git / blobdiff