%
-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996
%
\section[SimplVar]{Simplifier stuff related to variables}
-
+
\begin{code}
-#include "HsVersions.h"
-
module SimplVar (
completeVar,
- leastItCouldCost
+ simplBinder, simplBinders, simplTyBinder, simplTyBinders
) where
-IMPORT_Trace
-
-import SimplMonad
-import SimplEnv
-import PlainCore
-import TaggedCore
-import BasicLit ( isNoRepLit )
+#include "HsVersions.h"
-import AbsUniType ( getUniDataTyCon, getUniDataTyCon_maybe,
- getTyConFamilySize, isPrimType
+import {-# SOURCE #-} Simplify ( simplExpr )
+
+import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
+import CoreSyn
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ FormSummary, whnfOrBottom, okToInline,
+ smallEnoughToInline )
+import CoreUtils ( coreExprCc )
+import BinderInfo ( BinderInfo, noBinderInfo )
+
+import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
+import Id ( idType, getIdUnfolding, externallyVisibleId,
+ getIdSpecialisation, setIdSpecialisation,
+ idMustBeINLINEd, idHasNoFreeTyVars,
+ mkIdWithNewUniq, mkIdWithNewType,
+ IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
)
-import BinderInfo ( oneTextualOcc, oneSafeOcc )
-import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
- uNFOLDING_CON_DISCOUNT_WEIGHT
+import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, emptySpecEnv )
+import OccurAnal ( occurAnalyseGlobalExpr )
+import Literal ( isNoRepLit )
+import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
+import SimplEnv
+import SimplMonad
+import Type ( instantiateTy, mkTyVarTy )
+import TyCon ( tyConFamilySize )
+import TyVar ( TyVar, cloneTyVar,
+ isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
+ addOneToTyVarSet, elementOfTyVarSet
)
-import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) )
-import Id ( getIdUniType, getIdInfo )
-import IdInfo
-import Maybes ( maybeToBool, Maybe(..) )
-import Simplify ( simplExpr )
-import SimplUtils ( simplIdWantsToBeINLINEd )
-import MagicUFs
-import Pretty
-import Util
+import Maybes ( maybeToBool )
+import Outputable
\end{code}
%************************************************************************
This where all the heavy-duty unfolding stuff comes into its own.
\begin{code}
-completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr
+completeVar env inline_call var args result_ty
+
+ | maybeToBool maybe_magic_result
+ = tick MagicUnfold `thenSmpl_`
+ magic_result
+
+ -- Look for existing specialisations before
+ -- trying inlining
+ | maybeToBool maybe_specialisation
+ = tick SpecialisationDone `thenSmpl_`
+ 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)
-completeVar env var args
- = let
- boring_result = applyToArgs (CoVar var) args
- in
- case (lookupUnfolding env var) of
-
- LiteralForm lit
- | not (isNoRepLit lit)
- -- Inline literals, if they aren't no-repish things
- -> ASSERT( null args )
- returnSmpl (CoLit lit)
-
- ConstructorForm con ty_args val_args
- -- Always inline constructors.
- -- See comments before completeLetBinding
- -> ASSERT( null args )
- returnSmpl (CoCon con ty_args val_args)
-
- GeneralForm txt_occ form_summary template guidance
- -> considerUnfolding env var args
- txt_occ form_summary template guidance
-
- MagicForm str magic_fun
- -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result ->
- case result of
- Nothing -> returnSmpl boring_result
- Just magic_result ->
- {- pprTrace "MagicForm:- " (ppAbove
- (ppBesides [
- ppr PprDebug var,
- ppr PprDebug args])
- (ppBesides [
- ppStr "AFTER :- ",
- ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () ->
- -}
- tick MagicUnfold `thenSmpl_`
- returnSmpl magic_result
-
- IWantToBeINLINEd _ -> returnSmpl boring_result
-
- other -> returnSmpl boring_result
-\end{code}
+ | otherwise
+ = returnSmpl (mkGenApp (Var var') args)
+
+ where
+ (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 of
+ MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
+ env args
+ other -> Nothing
+ Just magic_result = maybe_magic_result
+
+ ---------- Unfolding stuff
+ has_unfolding = case unfolding of
+ CoreUnfolding _ _ _ -> True
+ other -> False
+
+ 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!!
+
+ ---------- Specialisation stuff
+ (ty_args, remaining_args) = initialTyArgs args
+ 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
+ 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
+
+
+
+
+-- costCentreOk checks that it's ok to inline this thing
+-- The time it *isn't* is this:
+--
+-- f x = let y = E in
+-- scc "foo" (...y...)
+--
+-- 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
+ = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs)
+\end{code}
%************************************************************************
%* *
-\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
+\section{Dealing with a single binder}
%* *
%************************************************************************
-We have very limited information about an unfolding expression: (1)~so
-many type arguments and so many value arguments expected---for our
-purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
-a single integer. (3)~An ``argument info'' vector. For this, what we
-have at the moment is a Boolean per argument position that says, ``I
-will look with great favour on an explicit constructor in this
-position.''
-
-Assuming we have enough type- and value arguments (if not, we give up
-immediately), then we see if the ``discounted size'' is below some
-(semi-arbitrary) threshold. It works like this: for every argument
-position where we're looking for a constructor AND WE HAVE ONE in our
-hands, we get a (again, semi-arbitrary) discount [proportion to the
-number of constructors in the type being scrutinized].
+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}
-considerUnfolding
- :: SimplEnv
- -> OutId -- Id we're thinking about
- -> [OutArg] -- Applied to these
- -> Bool -- If True then *always* inline,
- -- because it's the only one
- -> FormSummary
- -> InExpr -- Template for unfolding;
- -> UnfoldingGuidance -- To help us decide...
- -> SmplM PlainCoreExpr -- Result!
-
-considerUnfolding env var args txt_occ form_summary template guidance
- | switchIsOn sw_chkr EssentialUnfoldingsOnly
- = dont_go_for_it -- we're probably in a hurry in this simpl round...
-
- | do_deforest
- = pprTrace "" (ppBesides [ppStr "not attempting to unfold `",
- ppr PprDebug var,
- ppStr "' due to DEFOREST pragma"])
- dont_go_for_it
-
- | txt_occ
- = go_for_it
-
- | (case form_summary of {BottomForm -> True; other -> False} &&
- not (any isPrimType [ ty | (TypeArg ty) <- args ]))
- -- Always inline bottoming applications, unless
- -- there's a primitive type lurking around...
- = go_for_it
+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 this is a deforestable Id, then don't unfold it (the deforester
- -- will do it).
-
- case getInfo (getIdInfo var) of {
- DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `",
- ppr PprDebug var,
- ppStr "' due to DEFOREST pragma"])
- dont_go_for_it;
- Don'tDeforest ->
-
- case guidance of
- UnfoldNever -> dont_go_for_it
-
- UnfoldAlways -> go_for_it
-
- EssentialUnfolding -> go_for_it
-
- UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size
- -> if m_tys_wanted > no_tyargs
- || n_vals_wanted > no_valargs then
- --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var))
- dont_go_for_it
-
- else if n_vals_wanted == 0
- && looks_like_a_data_val_to_me then
- -- we are very keen on inlining data values
- -- (see comments elsewhere); we ignore any size issues!
- go_for_it
-
- else -- we try the fun stuff
- let
- discounted_size
- = discountedCost env con_discount size no_valargs is_con_vec valargs
- in
- if discounted_size <= unfold_use_threshold then
- go_for_it
- else
- --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance])
- dont_go_for_it
- }
- where
- sw_chkr = getSwitchChecker env
-
- unfold_use_threshold
- = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of
- Nothing -> uNFOLDING_USE_THRESHOLD
- Just xx -> xx
-
- con_discount -- ToDo: ************ get from a switch *********
- = uNFOLDING_CON_DISCOUNT_WEIGHT
-
- (tyargs, valargs, args_left) = decomposeArgs args
- no_tyargs = length tyargs
- no_valargs = length valargs
-
- looks_like_a_data_val_to_me
- = let
- (_,val_binders,body) = digForLambdas template
- in
- case (val_binders, body) of
- ([], CoCon _ _ _) -> True
- other -> False
-
- dont_go_for_it = returnSmpl (applyToArgs (CoVar var) args)
-
- go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) (
- tick UnfoldingDone `thenSmpl_`
- simplExpr env template args
- --)
-
-#if OMIT_DEFORESTER
- do_deforest = False
-#else
- do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
+ =
+#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
-\end{code}
-
-\begin{code}
-type ArgInfoVector = [Bool]
-
-discountedCost
- :: SimplEnv -- so we can look up things about the args
- -> Int -- the discount for a "constructor" hit;
- -- we multiply by the # of cons in the type.
- -> Int -- the size/cost of the expr
- -> Int -- the number of val args (== length args)
- -> ArgInfoVector -- what we know about the *use* of the arguments
- -> [OutAtom] -- *an actual set of value arguments*!
- -> Int
-
- -- If we apply an expression (usually a function) of given "costs"
- -- to a particular set of arguments (possibly none), what will
- -- the resulting expression "cost"?
-
-discountedCost env con_discount_weight size no_args is_con_vec args
- = ASSERT(no_args == length args)
- disc (size - no_args) is_con_vec args
- -- we start w/ a "discount" equal to the # of args...
- where
- disc size [] _ = size
- disc size _ [] = size
-
- disc size (want_con_here:want_cons) (arg:rest_args)
- = let
- full_price = disc size
- take_something_off v = let
- (tycon, _, _) = getUniDataTyCon (getIdUniType v)
- no_cons = case (getTyConFamilySize tycon) of
- Just n -> n
- reduced_size
- = size - (no_cons * con_discount_weight)
- in
- disc reduced_size
+ (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
- (if not want_con_here then
- full_price
- else
- case arg of
- CoLitAtom _ -> full_price
- CoVarAtom v -> case lookupUnfolding env v of
- ConstructorForm _ _ _ -> take_something_off v
- other_form -> full_price
-
- ) want_cons rest_args
+ 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}
-We use this one to avoid exporting inlinings that we ``couldn't possibly
-use'' on the other side. Can be overridden w/ flaggery.
-\begin{code}
-leastItCouldCost
- :: Int
- -> Int -- the size/cost of the expr
- -> Int -- number of value args
- -> ArgInfoVector -- what we know about the *use* of the arguments
- -> [UniType] -- NB: actual arguments *not* looked at;
- -- but we know their types
- -> Int
-
-leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys
- = ASSERT(no_val_args == length arg_tys)
- disc (size - no_val_args) is_con_vec arg_tys
- -- we start w/ a "discount" equal to the # of args...
+\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
- -- ToDo: rather sad that this isn't commoned-up w/ the one above...
+ ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
+ no_need_to_clone = not (tyvar `elementOfTyVarSet` tyvars) &&
+ not clone_binds_please
- disc size [] _ = size
- disc size _ [] = size
+ clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
+ sw_chkr = getSwitchChecker env
- disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys)
- = let
- take_something_off tycon
- = let
- no_cons = case (getTyConFamilySize tycon) of { Just n -> n }
- reduced_size
- = size - (no_cons * con_discount_weight)
- in
- reduced_size
- in
- if not want_con_here then
- disc size want_cons rest_arg_tys
- else
- case (getUniDataTyCon_maybe arg_ty, isPrimType arg_ty) of
- (Just (tycon, _, _), False) ->
- disc (take_something_off tycon) want_cons rest_arg_tys
-
- other -> disc size want_cons rest_arg_tys
+simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
+simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
\end{code}
-
projects / ghc-hetmet.git / blobdiff