% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplVar]{Simplifier stuff related to variables}
-
+
\begin{code}
-#include "HsVersions.h"
-
module SimplVar (
- completeVar
+ completeVar,
+ simplBinder, simplBinders, simplTyBinder, simplTyBinders
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(SmplLoop) ( simplExpr )
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Simplify ( simplExpr )
-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 CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ FormSummary, whnfOrBottom, okToInline,
+ smallEnoughToInline )
+import CoreUtils ( coreExprCc )
import BinderInfo ( BinderInfo, noBinderInfo )
-import CostCentre ( CostCentre, noCostCentreAttached )
-import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
- idMustBeINLINEd, GenId{-instance Outputable-}
+import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
+import Id ( idType, getIdUnfolding, externallyVisibleId,
+ getIdSpecialisation, setIdSpecialisation,
+ idMustBeINLINEd, idHasNoFreeTyVars,
+ mkIdWithNewUniq, mkIdWithNewType,
+ IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
)
-import SpecEnv ( SpecEnv, lookupSpecEnv )
-import IdInfo ( DeforestInfo(..) )
+import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, emptySpecEnv )
+import OccurAnal ( occurAnalyseGlobalExpr )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
---import Pretty ( ppBesides, ppStr )
import SimplEnv
import SimplMonad
+import Type ( instantiateTy, mkTyVarTy )
import TyCon ( tyConFamilySize )
-import Util ( pprTrace, assertPanic, panic )
+import TyVar ( TyVar, cloneTyVar,
+ isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
+ addOneToTyVarSet, elementOfTyVarSet
+ )
import Maybes ( maybeToBool )
+import Outputable
\end{code}
%************************************************************************
This where all the heavy-duty unfolding stuff comes into its own.
\begin{code}
-completeVar env var args
+completeVar env inline_call 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,
- -- 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_`
-#ifdef DEBUG
--- simplCount `thenSmpl` \ n ->
--- (if n > 3000 then
--- pprTrace "Ticks > 3000 and unfolding" (ppr PprDebug var)
--- else
--- id
--- )
-#endif
- simplExpr unfold_env unf_template args
-
+ -- Look for existing specialisations before
+ -- trying inlining
| maybeToBool maybe_specialisation
= tick SpecialisationDone `thenSmpl_`
- simplExpr (extendTyEnvList env spec_bindings)
- spec_template
- (map TyArg leftover_ty_args ++ remaining_args)
+ simplExpr (bindTyVars env spec_bindings)
+ (occurAnalyseGlobalExpr spec_template)
+ remaining_args
+ result_ty
+
+
+ -- Look for an unfolding. There's a binding for the
+ -- thing, but perhaps we want to inline it anyway
+ | has_unfolding
+ && (idMustBeINLINEd var ||
+ (not essential_unfoldings_only
+ -- 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)
+ && (inline_call || ok_to_inline)
+ && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)))
+ =
+{-
+ pprTrace "Unfolding" (ppr var) $
+ simplCount `thenSmpl` \ n ->
+ (if n > 1000 then
+ pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
+ else
+ id
+ )
+ (if n>4000 then
+ returnSmpl (mkGenApp (Var var) args)
+ else
+-}
+ tickUnfold var `thenSmpl_`
+ simplExpr unf_env unf_template args result_ty
+
+ | inline_call -- There was an InlineCall note, but we didn't inline!
+ = returnSmpl (mkGenApp (Note InlineCall (Var var')) args)
| otherwise
- = returnSmpl (mkGenApp (Var var) args)
+ = returnSmpl (mkGenApp (Var var') args)
where
- unfolding_from_id = getIdUnfolding var
+ (var', occ_info, unfolding) = case lookupOutIdEnv env var of
+ Just stuff -> stuff
+ Nothing -> (var, noBinderInfo, getIdUnfolding var)
---------- Magic unfolding stuff
- maybe_magic_result = case unfolding_from_id of
+ maybe_magic_result = case unfolding of
MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
env args
other -> Nothing
- (Just magic_result) = maybe_magic_result
+ Just magic_result = maybe_magic_result
---------- Unfolding stuff
- maybe_unfolding_info
- = case (lookupOutIdEnv env var, unfolding_from_id) of
+ has_unfolding = case unfolding of
+ CoreUnfolding _ _ _ -> True
+ other -> False
- (Just (_, occ_info, OutUnfolding enc_cc unf), _)
- -> Just (occ_info, setEnclosingCC env enc_cc, unf)
+ CoreUnfolding form guidance unf_template = unfolding
+ unf_env = zapSubstEnvs env
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
- (Just (_, occ_info, InUnfolding env_unf unf), _)
- -> Just (occ_info, env_unf, unf)
--- This combineSimplEnv is WRONG. InUnfoldings are used for
--- recursive decls, and we're relying on using the old unfold enf
--- to avoid getting outselves in a loop!
--- -> 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
- 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
+ maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
+ Just (spec_bindings, spec_template) = 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_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
+ is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee
+ ok_to_inline = okToInline var (whnfOrBottom form) small_enough occ_info
+ small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance
+ arg_evals = [is_evald arg | arg <- args, isValArg arg]
+
+ is_evald (VarArg v) = isEvaluated (lookupUnfolding 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
+
-- 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 (noCostCentreAttached cc_rhs)
\end{code}
+
+%************************************************************************
+%* *
+\section{Dealing with a single binder}
+%* *
+%************************************************************************
+
+When we hit a binder we may need to
+ (a) apply the the type envt (if non-empty) to its type
+ (b) apply the type envt and id envt to its SpecEnv (if it has one)
+ (c) give it a new unique to avoid name clashes
+
+\begin{code}
+simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
+simplBinder env (id, occ_info)
+ | no_need_to_clone -- Not in scope (or cloning disabled), so no need to clone
+ && empty_ty_subst -- No type substitution to do inside the Id
+ && isNullIdEnv id_subst -- No id substitution to do inside the Id
+ = let
+ env' = setIdEnv env (new_in_scope_ids id, id_subst)
+ in
+ returnSmpl (env', id)
+
+ | otherwise
+ =
+#if DEBUG
+ -- I reckon the empty-env thing should catch
+ -- most no-free-tyvars things, so this test should be redundant
+-- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
+#endif
+ (let
+ -- id1 has its type zapped
+ id1 | empty_ty_subst = id
+ | otherwise = mkIdWithNewType id ty'
+ -- id2 has its SpecEnv zapped (see comment inside Simplify.completeBind)
+ id2 | empty_spec_env = id1
+ | otherwise = setIdSpecialisation id1 emptySpecEnv
+ in
+ if no_need_to_clone then
+ -- No need to clone, but we *must* zap any current substitution
+ -- for the variable. For example:
+ -- (\x.e) with id_subst = [x |-> e']
+ -- Here we must simply zap the substitution for x
+ let
+ new_id_subst = delOneFromIdEnv id_subst id
+ new_env = setIdEnv env (new_in_scope_ids id2, new_id_subst)
+ in
+ returnSmpl (new_env, id2)
+ else
+ -- Must clone
+ getUniqueSmpl `thenSmpl` \ uniq ->
+ let
+ id3 = mkIdWithNewUniq id2 uniq
+ new_env = setIdEnv env (new_in_scope_ids id3,
+ addOneToIdEnv id_subst id (SubstVar id3))
+ in
+ returnSmpl (new_env, id3)
+ )
+ where
+ ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
+
+ empty_ty_subst = isEmptyTyVarEnv ty_subst
+ empty_spec_env = isEmptySpecEnv (getIdSpecialisation id)
+
+ no_need_to_clone = not need_to_clone
+ need_to_clone = not (externallyVisibleId id) &&
+ ( elemIdEnv id in_scope_ids || clone_binds_please)
+ {-
+ The SimplCloneBinds option isn't just here as another simplifier knob we can
+ twiddle. Prior to floating bindings outwards, we have to make sure that no
+ duplicate bindings exist as floating may cause bindings with identical
+ uniques to come into scope, with disastrous consequences.
+
+ To avoid this situation, we make sure that cloning is turned *on* in the
+ simplifier pass prior to running an outward floating pass.
+ -}
+ clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
+
+ new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
+
+ ty = idType id
+ ty' = instantiateTy ty_subst ty
+
+ sw_chkr = getSwitchChecker env
+
+
+simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
+simplBinders env binders = mapAccumLSmpl simplBinder env binders
+\end{code}
+
+\begin{code}
+simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
+simplTyBinder env tyvar
+ | no_need_to_clone
+ = -- No need to clone; but must zap any binding for tyvar
+ -- see comments with simplBinder above
+ let
+ env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar,
+ delFromTyVarEnv ty_subst tyvar)
+ in
+ returnSmpl (env', tyvar)
+
+ | otherwise -- Need to clone
+ = getUniqueSmpl `thenSmpl` \ uniq ->
+ let
+ tyvar' = cloneTyVar tyvar uniq
+ env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar',
+ addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar'))
+ in
+ returnSmpl (env', tyvar')
+ where
+ ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
+ no_need_to_clone = not (tyvar `elementOfTyVarSet` tyvars) &&
+ not clone_binds_please
+
+ clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
+ sw_chkr = getSwitchChecker env
+
+
+simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
+simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
+\end{code}
projects / ghc-hetmet.git / blobdiff