markDangerousOccs,
lookupRhsInfo, lookupOutIdEnv, isEvaluated,
extendEnvGivenBinding, extendEnvGivenNewRhs,
- extendEnvForRecBinding, extendEnvGivenRhsInfo,
+ extendEnvGivenRhsInfo,
lookForConstructor,
- getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
+ getSwitchChecker, switchIsSet, getSimplIntSwitch,
+ switchOffInlining, setCaseScrutinee,
setEnclosingCC, getEnclosingCC,
import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached )
import FiniteMap -- lots of things
import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
- applyTypeEnvToId,
+ applyTypeEnvToId, getInlinePragma,
nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
- SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
+ SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) )
import Literal ( isNoRepLit, Literal{-instances-} )
import Maybes ( maybeToBool, expectJust )
import Name ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar )
import Pretty
-import Type ( eqTy, applyTypeEnvToTy )
+import Type ( eqTy, applyTypeEnvToTy, SYN_IE(Type) )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
- SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
+ SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ,
+ SYN_IE(TyVar)
)
import Unique ( Unique{-instance Outputable-} )
-import UniqFM ( addToUFM_C, ufmToList, eltsUFM
+import UniqFM ( addToUFM_C, ufmToList, Uniquable(..)
)
---import UniqSet -- lots of things
import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
-import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
+import Util ( SYN_IE(Eager), appEager, returnEager, runEager,
+ zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) )
-type TypeEnv = TyVarEnv Type
-cmpType = panic "cmpType (SimplEnv)"
\end{code}
%************************************************************************
where
chkr' EssentialUnfoldingsOnly = SwBool True
chkr' other = chkr other
+
+setCaseScrutinee :: SimplEnv -> SimplEnv
+setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
+ where
+ chkr' SimplCaseScrutinee = SwBool True
+ chkr' other = chkr other
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+type TypeEnv = TyVarEnv Type
type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
where
new_ty_env = growTyVarEnvList ty_env pairs
-simplTy (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty
-simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id
+simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty)
+simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
\end{code}
%************************************************************************
\end{code}
\begin{code}
-lookupId :: SimplEnv -> Id -> OutArg
+lookupId :: SimplEnv -> Id -> Eager ans OutArg
lookupId (SimplEnv _ _ _ in_id_env _ _) id
= case (lookupIdEnv in_id_env id) of
- Just atom -> atom
- Nothing -> VarArg id
+ Just atom -> returnEager atom
+ Nothing -> returnEager (VarArg id)
\end{code}
\begin{code}
(OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
(_, NoRhsInfo) -> (id,occ, info1)
other -> (id,occ, info2)
-
---(id, occ, new_info)
-{-
- where
- new_info = case (info1, info2) of
- (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
- (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
- (_, NoRhsInfo) -> info1
- other -> info2
--}
\end{code}
isEvaluated other = False
\end{code}
+
+
+\begin{code}
+mkSimplUnfoldingGuidance chkr out_id rhs
+ = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
+
+extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
+extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ out_id occ_info rhs_info
+ = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+ where
+ new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
+ (out_id, occ_info, rhs_info)
+\end{code}
+
+
+\begin{code}
+modifyOccInfo out_id_env (uniq, new_occ)
+ = modifyIdEnv_Directly modify_fn out_id_env uniq
+ where
+ modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
+
+markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
+ = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+ where
+ new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
+ modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsubsection{The @ConAppMap@ type}
+%* *
+%************************************************************************
+
+The @ConAppMap@ maps applications of constructors (to value atoms)
+back to an association list that says "if the constructor was applied
+to one of these lists-of-Types, then this OutId is your man (in a
+non-gender-specific sense)". I.e., this is a reversed mapping for
+(part of) the main OutIdEnv
+
+\begin{code}
+type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
+
+data UnfoldConApp
+ = UCA OutId -- data constructor
+ [OutArg] -- *value* arguments; see use below
+\end{code}
+
+\begin{code}
+nullConApps = emptyFM
+
+extendConApps con_apps id (Con con args)
+ = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
+ where
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
+
+extendConApps con_apps id other_rhs = con_apps
+\end{code}
+
+\begin{code}
+lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
+ = case lookupFM con_apps (UCA con val_args) of
+ Nothing -> Nothing
+
+ Just assocs -> case [id | (tys, id) <- assocs,
+ and (zipWith eqTy tys ty_args)]
+ of
+ [] -> Nothing
+ (id:_) -> Just id
+ where
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
+
+\end{code}
+
+NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
+for nullary constructors, but now we only do constructor re-use in
+let-bindings the special case isn't necessary any more.
+
+\begin{verbatim}
+ = -- Don't re-use nullary constructors; it's a waste. Consider
+ -- let
+ -- a = leInt#! p q
+ -- in
+ -- case a of
+ -- True -> ...
+ -- False -> False
+ --
+ -- Here the False in the second case will get replace by "a", hardly
+ -- a good idea
+ Nothing
+\end{verbatim}
+
+
+The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
+it, so we can use it for a @FiniteMap@ key.
+
+\begin{code}
+instance Eq UnfoldConApp where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord UnfoldConApp where
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+ _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+
+instance Ord3 UnfoldConApp where
+ cmp = cmp_app
+
+cmp_app (UCA c1 as1) (UCA c2 as2)
+ = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
+ where
+ -- ToDo: make an "instance Ord3 CoreArg"???
+
+ cmp_arg (VarArg x) (VarArg y) = x `cmp` y
+ cmp_arg (LitArg x) (LitArg y) = x `cmp` y
+ cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
+ cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
+ cmp_arg x y
+ | tag x _LT_ tag y = LT_
+ | otherwise = GT_
+ where
+ tag (VarArg _) = ILIT(1)
+ tag (LitArg _) = ILIT(2)
+ tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
+ tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
+\end{code}
+
+
+
+
+
+============================ OLD ================================
+ This version was used when we use the *simplified* RHS of a
+ let as the thing's unfolding. The has the nasty property described
+ in the following comments. Much worse, it can fail to terminate
+ on recursive things. Consider
+
+ letrec f = \x -> let z = f x' in ...
+
+ in
+ let n = f y
+ in
+ case n of { ... }
+
+ If we bind n to its *simplified* RHS, we then *re-simplify* it when
+ we inline n. Then we may well inline f; and then the same thing
+ happens with z!
+
+
@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
of a new binding. There is a horrid case we have to take care about,
due to Andr\'e Santos:
extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
occ_info out_id rhs
- = let
- s_env = SimplEnv chkr encl_cc ty_env in_id_env out_id_env new_con_apps
- s_env_uf = SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding new_con_apps
- in
- case guidance of
- -- Cheap and nasty hack to force strict insertion.
- UnfoldNever ->
- if isEmptyFM new_con_apps then s_env else s_env
- other ->
- if isEmptyFM new_con_apps then s_env_uf else s_env_uf
+ = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
where
- new_con_apps = extendConApps con_apps out_id rhs
-{-
new_out_id_env = case guidance of
UnfoldNever -> out_id_env -- No new stuff to put in
other -> out_id_env_with_unfolding
--}
- -- If there is an unfolding, we add rhs-info for out_id,
- -- *and* modify the occ info for rhs's interesting free variables.
- --
- -- If the out_id is already in the OutIdEnv, then just replace the
- -- unfolding, leaving occurrence info alone (this must then
- -- be a call via extendEnvGivenNewRhs).
- out_id_env_with_unfolding = foldl modifyOccInfo env1 full_fv_occ_info
- -- full_fv_occ_info combines the occurrence of the current binder
- -- with the occurrences of its RHS's free variables.
- full_fv_occ_info = [ (uniq, fv_occ `andBinderInfo` occ_info)
- | (uniq,fv_occ) <- ufmToList fv_occ_info
+
+ new_con_apps = _scc_ "eegnr.conapps"
+ extendConApps con_apps out_id rhs
+
+ -- Modify the occ info for rhs's interesting free variables.
+ out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
+ foldl modifyOccInfo env1 full_fv_occ_info
+ -- NB: full_fv_occ_info *combines* the occurrence of the current binder
+ -- with the occurrences of its RHS's free variables. That's to take
+ -- account of:
+ -- let a = \x -> BIG in
+ -- let b = \f -> f a
+ -- in ...b...b...b...
+ -- Here "a" occurs exactly once. "b" simplifies to a small value.
+ -- So "b" will be inlined at each call site, and there's a good chance
+ -- that "a" will too. So we'd better modify "a"s occurrence info to
+ -- record the fact that it can now occur many times by virtue that "b" can.
+
+ full_fv_occ_info = _scc_ "eegnr.full_fv"
+ [ (uniq, fv_occ `andBinderInfo` occ_info)
+ | (uniq, fv_occ) <- ufmToList fv_occ_info
]
- env1 = addToUFM_C modifyOutEnvItem out_id_env out_id
+
+ -- Add an unfolding and rhs_info for the new Id.
+ -- If the out_id is already in the OutIdEnv (which can happen if
+ -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
+ -- then just replace the unfolding, leaving occurrence info alone.
+ env1 = _scc_ "eegnr.modify_out"
+ addToUFM_C modifyOutEnvItem out_id_env out_id
(out_id, occ_info, rhs_info)
-- Occurrence-analyse the RHS
-- The "interesting" free variables we want occurrence info for are those
-- in the OutIdEnv that have only a single occurrence right now.
- (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
- interesting_fvs = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env]
+ (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
+ occurAnalyseExpr is_interesting rhs
+
+ is_interesting v = _scc_ "eegnr.mkidset"
+ case lookupIdEnv out_id_env v of
+ Just (_, OneOcc _ _ _ _ _, _) -> True
+ other -> False
-- Compute unfolding details
rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
- form_summary = mkFormSummary rhs
-
- guidance = mkSimplUnfoldingGuidance chkr out_id rhs
+ form_summary = _scc_ "eegnr.form_sum"
+ mkFormSummary rhs
+ guidance = _scc_ "eegnr.guidance"
+ mkSimplUnfoldingGuidance chkr out_id rhs
-- Compute cost centre for thing
unf_cc | noCostCentreAttached expr_cc = encl_cc
+
+========================== OLD [removed SLPJ March 97] ====================
+
+I removed the attempt to inline recursive bindings when I discovered
+a program that made the simplifier loop (nofib/spectral/hartel/typecheck/Main.hs)
+
+The nasty case is this:
+
+ letrec f = \x -> let z = f x' in ...
+
+ in
+ let n = f y
+ in
+ case n of { ... }
+
+If we bind n to its *simplified* RHS, we then *re-simplify* it when we
+inline n. Then we may well inline f; and then the same thing happens
+with z!
+
Recursive bindings
~~~~~~~~~~~~~~~~~~
We need to be pretty careful when extending
which is OK if not clever.
+
+
\begin{code}
+{-
extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
(out_id, ((_,occ_info), old_rhs))
= case (form_summary, guidance) of
rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
form_summary = mkFormSummary old_rhs
guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
-
-
-mkSimplUnfoldingGuidance chkr out_id rhs
- = case calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs of
- UnfoldNever -> UnfoldNever
- v -> v
- where
- inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
-
-extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
-extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
- out_id occ_info rhs_info
- = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
- where
- new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
- (out_id, occ_info, rhs_info)
-\end{code}
-
-
-\begin{code}
-modifyOccInfo out_id_env (uniq, new_occ)
- = modifyIdEnv_Directly modify_fn out_id_env uniq
- where
- modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
-
-markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
- = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
- where
- new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
- modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsubsection{The @ConAppMap@ type}
-%* *
-%************************************************************************
-
-The @ConAppMap@ maps applications of constructors (to value atoms)
-back to an association list that says "if the constructor was applied
-to one of these lists-of-Types, then this OutId is your man (in a
-non-gender-specific sense)". I.e., this is a reversed mapping for
-(part of) the main OutIdEnv
-
-\begin{code}
-type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
-
-data UnfoldConApp
- = UCA OutId -- data constructor
- [OutArg] -- *value* arguments; see use below
-\end{code}
-
-\begin{code}
-nullConApps = emptyFM
-
-extendConApps con_apps id (Con con args)
- = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
- where
- val_args = filter isValArg args -- Literals and Ids
- ty_args = [ty | TyArg ty <- args] -- Just types
-
-extendConApps con_apps id other_rhs = con_apps
-\end{code}
-
-\begin{code}
-lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
- = case lookupFM con_apps (UCA con val_args) of
- Nothing -> Nothing
-
- Just assocs -> case [id | (tys, id) <- assocs,
- and (zipWith eqTy tys ty_args)]
- of
- [] -> Nothing
- (id:_) -> Just id
- where
- val_args = filter isValArg args -- Literals and Ids
- ty_args = [ty | TyArg ty <- args] -- Just types
-
-\end{code}
-
-NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
-for nullary constructors, but now we only do constructor re-use in
-let-bindings the special case isn't necessary any more.
-
-\begin{verbatim}
- = -- Don't re-use nullary constructors; it's a waste. Consider
- -- let
- -- a = leInt#! p q
- -- in
- -- case a of
- -- True -> ...
- -- False -> False
- --
- -- Here the False in the second case will get replace by "a", hardly
- -- a good idea
- Nothing
-\end{verbatim}
-
-
-The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
-it, so we can use it for a @FiniteMap@ key.
-
-\begin{code}
-instance Eq UnfoldConApp where
- a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
-
-instance Ord UnfoldConApp where
- a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-
-instance Ord3 UnfoldConApp where
- cmp = cmp_app
-
-cmp_app (UCA c1 as1) (UCA c2 as2)
- = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
- where
- -- ToDo: make an "instance Ord3 CoreArg"???
-
- cmp_arg (VarArg x) (VarArg y) = x `cmp` y
- cmp_arg (LitArg x) (LitArg y) = x `cmp` y
- cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
- cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
- cmp_arg x y
- | tag x _LT_ tag y = LT_
- | otherwise = GT_
- where
- tag (VarArg _) = ILIT(1)
- tag (LitArg _) = ILIT(2)
- tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
- tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
+-}
\end{code}
-
-
-
projects / ghc-hetmet.git / commitdiff