2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplEnv]{Environment stuff for the simplifier}
7 #include "HsVersions.h"
10 nullSimplEnv, combineSimplEnv,
11 pprSimplEnv, -- debugging only
13 extendTyEnv, extendTyEnvList,
16 extendIdEnvWithAtom, extendIdEnvWithAtoms,
17 extendIdEnvWithClone, extendIdEnvWithClones,
22 lookupRhsInfo, lookupOutIdEnv, isEvaluated,
23 extendEnvGivenBinding, extendEnvGivenNewRhs,
24 extendEnvGivenRhsInfo,
28 getSwitchChecker, switchIsSet, getSimplIntSwitch,
29 switchOffInlining, setCaseScrutinee,
31 setEnclosingCC, getEnclosingCC,
34 SYN_IE(SwitchChecker),
36 SYN_IE(InIdEnv), SYN_IE(InTypeEnv),
40 SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType),
41 SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
43 SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg),
44 SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg)
49 IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
51 import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo,
52 BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
54 import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
55 SimplifierSwitch(..), SwitchResult(..)
58 import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup,
59 Unfolding(..), UfExpr, RdrName,
60 SimpleUnfolding(..), FormSummary(..),
61 calcUnfoldingGuidance, UnfoldingGuidance(..)
63 import CoreUtils ( coreExprCc, unTagBinders )
64 import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached )
65 import FiniteMap -- lots of things
66 import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
67 applyTypeEnvToId, getInlinePragma,
68 nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
69 addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
70 SYN_IE(IdEnv), SYN_IE(IdSet), GenId, SYN_IE(Id) )
71 import Literal ( isNoRepLit, Literal{-instances-} )
72 import Maybes ( maybeToBool, expectJust )
73 import Name ( isLocallyDefined )
74 import OccurAnal ( occurAnalyseExpr )
75 import Outputable ( PprStyle(..), Outputable(..){-instances-} )
76 import PprCore -- various instances
77 import PprType ( GenType, GenTyVar )
79 import Type ( eqTy, applyTypeEnvToTy, SYN_IE(Type) )
80 import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
81 SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ,
84 import Unique ( Unique{-instance Outputable-} )
85 import UniqFM ( addToUFM_C, ufmToList, Uniquable(..)
87 import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
88 import Util ( SYN_IE(Eager), appEager, returnEager, runEager,
89 zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) )
93 %************************************************************************
95 \subsection[Simplify-types]{Type declarations}
97 %************************************************************************
100 type InId = Id -- Not yet cloned
101 type InBinder = (InId, BinderInfo)
102 type InType = Type -- Ditto
103 type InBinding = SimplifiableCoreBinding
104 type InExpr = SimplifiableCoreExpr
105 type InAlts = SimplifiableCoreCaseAlts
106 type InDefault = SimplifiableCoreCaseDefault
107 type InArg = SimplifiableCoreArg
109 type OutId = Id -- Cloned
111 type OutType = Type -- Cloned
112 type OutBinding = CoreBinding
113 type OutExpr = CoreExpr
114 type OutAlts = CoreCaseAlts
115 type OutDefault = CoreCaseDefault
116 type OutArg = CoreArg
118 type SwitchChecker = SimplifierSwitch -> SwitchResult
121 %************************************************************************
123 \subsubsection{The @SimplEnv@ type}
125 %************************************************************************
128 INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
129 this? WDP 94/06) This allows us to neglect keeping everything paired
130 with its static environment.
132 The environment contains bindings for all
134 {\em locally-defined}
137 For such things, any unfolding is found in the environment, not in the
138 Id. Unfoldings in the Id itself are used only for imported things
139 (otherwise we get trouble because we have to simplify the unfoldings
140 inside the Ids, etc.).
146 CostCentre -- The enclosing cost-centre (when profiling)
147 InTypeEnv -- Maps old type variables to new clones
148 InIdEnv -- Maps locally-bound Ids to new clones
149 OutIdEnv -- Info about the values of OutIds
150 ConAppMap -- Maps constructor applications back to OutIds
153 nullSimplEnv :: SwitchChecker -> SimplEnv
156 = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
158 combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
159 combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps)
160 new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ )
161 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
163 pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
167 %************************************************************************
169 \subsubsection{Command-line switches}
171 %************************************************************************
174 getSwitchChecker :: SimplEnv -> SwitchChecker
175 getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
177 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
178 switchIsSet (SimplEnv chkr _ _ _ _ _) switch
179 = switchIsOn chkr switch
181 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
182 getSimplIntSwitch chkr switch
183 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
186 setCaseScrutinee :: SimplEnv -> SimplEnv
187 setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
188 = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
190 chkr' SimplCaseScrutinee = SwBool True
191 chkr' other = chkr other
194 @switchOffInlining@ is used to prepare the environment for simplifying
195 the RHS of an Id that's marked with an INLINE pragma. It is going to
196 be inlined wherever they are used, and then all the inlining will take
197 effect. Meanwhile, there isn't much point in doing anything to the
198 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
200 (a) not doing so will inline a worker straight back into its wrapper!
202 and (b) Consider the following example
207 in ...g...g...g...g...g...
209 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
210 and thence copied multiple times when g is inlined.
212 Andy disagrees! Example:
213 all xs = foldr (&&) True xs
214 any p = all . map p {-# INLINE any #-}
216 Problem: any won't get deforested, and so if it's exported and
217 the importer doesn't use the inlining, (eg passes it as an arg)
218 then we won't get deforestation at all.
219 We havn't solved this problem yet!
221 We prepare the envt by simply discarding the out_id_env, which has
222 all the unfolding info. At one point we did it by modifying the chkr so
223 that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
224 simplifications happening in the body of the RHS.
227 switchOffInlining :: SimplEnv -> SimplEnv
228 switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
229 = SimplEnv chkr encl_cc ty_env in_id_env nullIdEnv nullConApps
232 %************************************************************************
234 \subsubsection{The ``enclosing cost-centre''}
236 %************************************************************************
239 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
241 setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
242 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
244 getEnclosingCC :: SimplEnv -> CostCentre
245 getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
248 %************************************************************************
250 \subsubsection{The @TypeEnv@ part}
252 %************************************************************************
255 type TypeEnv = TyVarEnv Type
256 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
258 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
259 extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
260 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
262 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
264 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
265 extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
266 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
268 new_ty_env = growTyVarEnvList ty_env pairs
270 simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty)
271 simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
274 %************************************************************************
276 \subsubsection{The ``Id env'' part}
278 %************************************************************************
281 type InIdEnv = IdEnv OutArg -- Maps InIds to their value
282 -- Usually this is just the cloned Id, but if
283 -- if the orig defn is a let-binding, and
284 -- the RHS of the let simplifies to an atom,
285 -- we just bind the variable to that atom, and
290 lookupId :: SimplEnv -> Id -> Eager ans OutArg
292 lookupId (SimplEnv _ _ _ in_id_env _ _) id
293 = case (lookupIdEnv in_id_env id) of
294 Just atom -> returnEager atom
295 Nothing -> returnEager (VarArg id)
302 -> OutArg{-Val args only, please-}
305 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
306 (in_id,occ_info) atom
308 LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
309 VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env
310 (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
311 --SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
313 new_in_id_env = addOneToIdEnv in_id_env in_id atom
315 new_out_id_env = case atom of
316 LitArg _ -> out_id_env
317 VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
320 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
321 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
324 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
326 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
328 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
330 new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
332 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
333 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
335 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
337 new_in_id_env = growIdEnvList in_id_env bindings
338 bindings = zipEqual "extendIdEnvWithClones"
339 [id | (id,_) <- in_binders]
343 %************************************************************************
345 \subsubsection{The @OutIdEnv@}
347 %************************************************************************
350 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
351 both locally-bound ones, and perhaps some imported ones too.
354 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
358 The "Id" part is just so that we can recover the domain of the mapping, which
359 IdEnvs don't allow directly.
361 The @BinderInfo@ tells about the occurrences of the @OutId@.
362 Anything that isn't in here should be assumed to occur many times.
363 We keep this info so we can modify it when something changes.
365 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
368 data RhsInfo = NoRhsInfo
369 | OtherLit [Literal] -- It ain't one of these
370 | OtherCon [Id] -- It ain't one of these
372 | InUnfolding SimplEnv -- Un-simplified unfolding
373 SimpleUnfolding -- (need to snag envts therefore)
375 | OutUnfolding CostCentre
376 SimpleUnfolding -- Already-simplified unfolding
378 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
379 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
381 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
383 = case lookupOutIdEnv env id of
384 Just (_,_,info) -> info
387 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
388 -> (OutId, BinderInfo, RhsInfo)
389 -> (OutId, BinderInfo, RhsInfo)
390 modifyOutEnvItem (id, occ, info1) (_, _, info2)
391 = case (info1, info2) of
392 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
393 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
394 (_, NoRhsInfo) -> (id,occ, info1)
395 other -> (id,occ, info2)
400 isEvaluated :: RhsInfo -> Bool
401 isEvaluated (OtherLit _) = True
402 isEvaluated (OtherCon _) = True
403 isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
404 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
405 isEvaluated other = False
411 mkSimplUnfoldingGuidance chkr out_id rhs
412 = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
414 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
415 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
416 out_id occ_info rhs_info
417 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
419 new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
420 (out_id, occ_info, rhs_info)
425 modifyOccInfo out_id_env (uniq, new_occ)
426 = modifyIdEnv_Directly modify_fn out_id_env uniq
428 modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
430 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
431 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
433 new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
434 modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
439 %************************************************************************
441 \subsubsection{The @ConAppMap@ type}
443 %************************************************************************
445 The @ConAppMap@ maps applications of constructors (to value atoms)
446 back to an association list that says "if the constructor was applied
447 to one of these lists-of-Types, then this OutId is your man (in a
448 non-gender-specific sense)". I.e., this is a reversed mapping for
449 (part of) the main OutIdEnv
452 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
455 = UCA OutId -- data constructor
456 [OutArg] -- *value* arguments; see use below
460 nullConApps = emptyFM
462 extendConApps con_apps id (Con con args)
463 = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
465 val_args = filter isValArg args -- Literals and Ids
466 ty_args = [ty | TyArg ty <- args] -- Just types
468 extendConApps con_apps id other_rhs = con_apps
472 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
473 = case lookupFM con_apps (UCA con val_args) of
476 Just assocs -> case [id | (tys, id) <- assocs,
477 and (zipWith eqTy tys ty_args)]
482 val_args = filter isValArg args -- Literals and Ids
483 ty_args = [ty | TyArg ty <- args] -- Just types
487 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
488 for nullary constructors, but now we only do constructor re-use in
489 let-bindings the special case isn't necessary any more.
492 = -- Don't re-use nullary constructors; it's a waste. Consider
500 -- Here the False in the second case will get replace by "a", hardly
506 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
507 it, so we can use it for a @FiniteMap@ key.
510 instance Eq UnfoldConApp where
511 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
512 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
514 instance Ord UnfoldConApp where
515 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
516 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
517 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
518 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
519 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
521 instance Ord3 UnfoldConApp where
524 cmp_app (UCA c1 as1) (UCA c2 as2)
525 = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
527 -- ToDo: make an "instance Ord3 CoreArg"???
529 cmp_arg (VarArg x) (VarArg y) = x `cmp` y
530 cmp_arg (LitArg x) (LitArg y) = x `cmp` y
531 cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
532 cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
534 | tag x _LT_ tag y = LT_
537 tag (VarArg _) = ILIT(1)
538 tag (LitArg _) = ILIT(2)
539 tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
540 tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
547 ============================ OLD ================================
548 This version was used when we use the *simplified* RHS of a
549 let as the thing's unfolding. The has the nasty property described
550 in the following comments. Much worse, it can fail to terminate
551 on recursive things. Consider
553 letrec f = \x -> let z = f x' in ...
560 If we bind n to its *simplified* RHS, we then *re-simplify* it when
561 we inline n. Then we may well inline f; and then the same thing
565 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
566 of a new binding. There is a horrid case we have to take care about,
567 due to Andr\'e Santos:
569 type Array_type b = Array Int b;
570 type Descr_type = (Int,Int);
572 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
573 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
577 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
578 f_aareorder a_index a_ar=
580 f_aareorder' a_i= a_ar ! (a_index ! a_i)
581 } in tabulate f_aareorder' (bounds a_ar);
582 r_index=tabulate ((+) 1) (1,1);
583 arr = listArray (1,1) a_xs;
584 arg = f_aareorder r_index arr
587 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
589 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
590 in tabulate f_aareorder' (bounds arr)
592 Note that r_index is not inlined, because it was bound to a_index which
593 occurs inside a lambda.
595 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
596 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
597 analyse it, we won't spot the inside-lambda property of r_index, so r_index
598 will get inlined inside the lambda. AARGH.
600 Solution: when we occurrence-analyse the new RHS we have to go back
601 and modify the info recorded in the UnfoldEnv for the free vars
602 of the RHS. In the example we'd go back and record that r_index is now used
606 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
607 extendEnvGivenNewRhs env out_id rhs
608 = extendEnvGivenBinding env noBinderInfo out_id rhs
610 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
611 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
613 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
615 new_out_id_env = case guidance of
616 UnfoldNever -> out_id_env -- No new stuff to put in
617 other -> out_id_env_with_unfolding
619 new_con_apps = _scc_ "eegnr.conapps"
620 extendConApps con_apps out_id rhs
622 -- Modify the occ info for rhs's interesting free variables.
623 out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
624 foldl modifyOccInfo env1 full_fv_occ_info
625 -- NB: full_fv_occ_info *combines* the occurrence of the current binder
626 -- with the occurrences of its RHS's free variables. That's to take
628 -- let a = \x -> BIG in
630 -- in ...b...b...b...
631 -- Here "a" occurs exactly once. "b" simplifies to a small value.
632 -- So "b" will be inlined at each call site, and there's a good chance
633 -- that "a" will too. So we'd better modify "a"s occurrence info to
634 -- record the fact that it can now occur many times by virtue that "b" can.
636 full_fv_occ_info = _scc_ "eegnr.full_fv"
637 [ (uniq, fv_occ `andBinderInfo` occ_info)
638 | (uniq, fv_occ) <- ufmToList fv_occ_info
641 -- Add an unfolding and rhs_info for the new Id.
642 -- If the out_id is already in the OutIdEnv (which can happen if
643 -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
644 -- then just replace the unfolding, leaving occurrence info alone.
645 env1 = _scc_ "eegnr.modify_out"
646 addToUFM_C modifyOutEnvItem out_id_env out_id
647 (out_id, occ_info, rhs_info)
649 -- Occurrence-analyse the RHS
650 -- The "interesting" free variables we want occurrence info for are those
651 -- in the OutIdEnv that have only a single occurrence right now.
652 (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
653 occurAnalyseExpr is_interesting rhs
655 is_interesting v = _scc_ "eegnr.mkidset"
656 case lookupIdEnv out_id_env v of
657 Just (_, OneOcc _ _ _ _ _, _) -> True
660 -- Compute unfolding details
661 rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
662 form_summary = _scc_ "eegnr.form_sum"
664 guidance = _scc_ "eegnr.guidance"
665 mkSimplUnfoldingGuidance chkr out_id rhs
667 -- Compute cost centre for thing
668 unf_cc | noCostCentreAttached expr_cc = encl_cc
669 | otherwise = expr_cc
671 expr_cc = coreExprCc rhs
677 ========================== OLD [removed SLPJ March 97] ====================
679 I removed the attempt to inline recursive bindings when I discovered
680 a program that made the simplifier loop (nofib/spectral/hartel/typecheck/Main.hs)
682 The nasty case is this:
684 letrec f = \x -> let z = f x' in ...
691 If we bind n to its *simplified* RHS, we then *re-simplify* it when we
692 inline n. Then we may well inline f; and then the same thing happens
697 We need to be pretty careful when extending
698 the environment with RHS info in recursive groups.
700 Here's a nasty example:
708 Here, r occurs exactly once, so we may reasonably inline r in t's RHS.
709 But the pre-simplified t's rhs is an atom, r, so we may also decide to
710 inline t everywhere. But if we do *both* these reasonable things we get
718 Bad news! (f x) is duplicated! (The t in the body doesn't get
719 inlined because by the time the recursive group is done we see that
720 t's RHS isn't an atom.)
722 Our solution is this:
723 (a) we inline un-simplified RHSs, and then simplify
724 them in a clone-only environment.
725 (b) we inline only variables and values
731 x = ...t... ==> x = ...r...
735 Now t is dead, and we're home.
737 Most silly x=y bindings in recursive group will go away. But not all:
742 Here, we can't inline x because it's in an argument position. so we'll just replace
743 with a clone of y. Instead we'll probably inline y (a small value) to give
748 which is OK if not clever.
754 extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
755 (out_id, ((_,occ_info), old_rhs))
756 = case (form_summary, guidance) of
757 (_, UnfoldNever) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in
758 (ValueForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
759 (VarForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
760 other -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- Not a value or variable
762 -- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
765 new_out_id_env = case (form_summary, guidance) of
766 (_, UnfoldNever) -> out_id_env -- No new stuff to put in
767 (ValueForm, _) -> out_id_env_with_unfolding
768 (VarForm, _) -> out_id_env_with_unfolding
769 other -> out_id_env -- Not a value or variable
771 -- If there is an unfolding, we add rhs-info for out_id,
772 -- No need to modify occ info because RHS is pre-simplification
773 out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id
774 (out_id, occ_info, rhs_info)
776 -- Compute unfolding details
777 -- Note that we use the "old" environment, that just has clones of the rec-bound vars,
778 -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once.
779 -- Only if the thing is still small enough next time round will we inline again.
780 rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
781 form_summary = mkFormSummary old_rhs
782 guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)