%
-% (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(..),
+ SimpleUnfolding(..),
+ FormSummary, whnfOrBottom,
+ smallEnoughToInline )
+import Specialise ( substSpecEnvRhs )
+import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
+
+import CostCentre ( CostCentre, isCurrentCostCentre )
+import Id ( idType, getIdInfo, getIdUnfolding,
+ getIdSpecialisation, setIdSpecialisation,
+ idMustBeINLINEd, idHasNoFreeTyVars,
+ mkIdWithNewUniq, mkIdWithNewType,
+ elemIdEnv, isNullIdEnv, addOneToIdEnv
)
-import BinderInfo ( oneTextualOcc, oneSafeOcc )
-import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
- uNFOLDING_CON_DISCOUNT_WEIGHT
+import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
+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,
+ 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 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
+ | ( 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)
+ && ok_to_inline
+ && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env)
+ )
+ = -- pprTrace "Unfolding" (ppr var) $
+ unfold var unf_env unf_template args result_ty
-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
+ info_from_env = lookupOutIdEnv env var
+ var' = case info_from_env of
+ Just (var', _, _) -> var'
+ Nothing -> var
+
+ unfolding_from_id = getIdUnfolding var
+
+ ---------- Magic unfolding stuff
+ maybe_magic_result = case unfolding_from_id of
+ MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
+ env args
+ other -> Nothing
+ Just magic_result = maybe_magic_result
+
+ maybe_unfolding_info
+ = case (info_from_env, unfolding_from_id) of
+
+ (Just (_, occ_info, OutUnfolding enc_cc unf), _)
+ -> Just (occ_info, setEnclosingCC env enc_cc, unf)
+
+ (_, CoreUnfolding unf)
+ -> Just (noBinderInfo, env, unf)
+
+ other -> Nothing
+
+ Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info
+ SimpleUnfolding form guidance unf_template = simple_unfolding
+
+ ---------- Specialisation stuff
+ (ty_args, remaining_args) = initialTyArgs args
+ maybe_specialisation = lookupSpecEnv (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 (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 (lookupRhsInfo env v)
+ is_evald (LitArg l) = True
+
+
+-- 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 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
+-- 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 (isCurrentCostCentre 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, _)
+ | not_in_scope -- Not in scope, 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 (addOneToIdEnv in_scope_ids id 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
- && rhs_looks_like_a_CoCon 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
-
- rhs_looks_like_a_CoCon
- = 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
+ id2 | isEmptySpecEnv spec_env = id1
+ | otherwise = setIdSpecialisation id spec_env'
+ in
+ if not_in_scope then
+ -- No need to clone
+ let
+ env' = setIdEnv env (addOneToIdEnv in_scope_ids id id2, id_subst)
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
-\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...
+ returnSmpl (env', id2)
+ else
+ -- Must clone
+ getUniqueSmpl `thenSmpl` \ uniq ->
+ let
+ id3 = mkIdWithNewUniq id2 uniq
+ env' = setIdEnv env (addOneToIdEnv in_scope_ids id3 id3,
+ addOneToIdEnv id_subst id (VarArg id3))
+ in
+ returnSmpl (env', id3)
+ )
where
- -- ToDo: rather sad that this isn't commoned-up w/ the one above...
+ ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
+ empty_ty_subst = isEmptyTyVarEnv ty_subst
+ not_in_scope = not (id `elemIdEnv` in_scope_ids)
- disc size [] _ = size
- disc size _ [] = size
+ ty = idType id
+ ty' = instantiateTy ty_subst ty
- 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 }
+ spec_env = getIdSpecialisation id
+ spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
- 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
+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
+ | not (tyvar `elementOfTyVarSet` tyvars) -- No need to clone
+ = let
+ env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst)
+ 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
+
+simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
+simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
+\end{code}