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 ( Outputable(..){-instances-} )
76 import PprCore -- various instances
77 import PprStyle ( PprStyle(..) )
78 import PprType ( GenType, GenTyVar )
80 import Type ( eqTy, applyTypeEnvToTy, SYN_IE(Type) )
81 import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
82 SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ,
85 import Unique ( Unique{-instance Outputable-} )
86 import UniqFM ( addToUFM_C, ufmToList, Uniquable(..)
88 import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
89 import Util ( SYN_IE(Eager), appEager, returnEager, runEager,
90 zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) )
94 %************************************************************************
96 \subsection[Simplify-types]{Type declarations}
98 %************************************************************************
101 type InId = Id -- Not yet cloned
102 type InBinder = (InId, BinderInfo)
103 type InType = Type -- Ditto
104 type InBinding = SimplifiableCoreBinding
105 type InExpr = SimplifiableCoreExpr
106 type InAlts = SimplifiableCoreCaseAlts
107 type InDefault = SimplifiableCoreCaseDefault
108 type InArg = SimplifiableCoreArg
110 type OutId = Id -- Cloned
112 type OutType = Type -- Cloned
113 type OutBinding = CoreBinding
114 type OutExpr = CoreExpr
115 type OutAlts = CoreCaseAlts
116 type OutDefault = CoreCaseDefault
117 type OutArg = CoreArg
119 type SwitchChecker = SimplifierSwitch -> SwitchResult
122 %************************************************************************
124 \subsubsection{The @SimplEnv@ type}
126 %************************************************************************
129 INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
130 this? WDP 94/06) This allows us to neglect keeping everything paired
131 with its static environment.
133 The environment contains bindings for all
135 {\em locally-defined}
138 For such things, any unfolding is found in the environment, not in the
139 Id. Unfoldings in the Id itself are used only for imported things
140 (otherwise we get trouble because we have to simplify the unfoldings
141 inside the Ids, etc.).
147 CostCentre -- The enclosing cost-centre (when profiling)
148 InTypeEnv -- Maps old type variables to new clones
149 InIdEnv -- Maps locally-bound Ids to new clones
150 OutIdEnv -- Info about the values of OutIds
151 ConAppMap -- Maps constructor applications back to OutIds
154 nullSimplEnv :: SwitchChecker -> SimplEnv
157 = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
159 combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
160 combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps)
161 new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ )
162 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
164 pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
168 %************************************************************************
170 \subsubsection{Command-line switches}
172 %************************************************************************
175 getSwitchChecker :: SimplEnv -> SwitchChecker
176 getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
178 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
179 switchIsSet (SimplEnv chkr _ _ _ _ _) switch
180 = switchIsOn chkr switch
182 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
183 getSimplIntSwitch chkr switch
184 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
187 switchOffInlining :: SimplEnv -> SimplEnv
188 switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
189 = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
191 chkr' EssentialUnfoldingsOnly = SwBool True
192 chkr' other = chkr other
194 setCaseScrutinee :: SimplEnv -> SimplEnv
195 setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
196 = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
198 chkr' SimplCaseScrutinee = SwBool True
199 chkr' other = chkr other
202 %************************************************************************
204 \subsubsection{The ``enclosing cost-centre''}
206 %************************************************************************
209 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
211 setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
212 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
214 getEnclosingCC :: SimplEnv -> CostCentre
215 getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
218 %************************************************************************
220 \subsubsection{The @TypeEnv@ part}
222 %************************************************************************
225 type TypeEnv = TyVarEnv Type
226 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
228 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
229 extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
230 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
232 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
234 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
235 extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
236 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
238 new_ty_env = growTyVarEnvList ty_env pairs
240 simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (applyTypeEnvToTy ty_env ty)
241 simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
244 %************************************************************************
246 \subsubsection{The ``Id env'' part}
248 %************************************************************************
251 type InIdEnv = IdEnv OutArg -- Maps InIds to their value
252 -- Usually this is just the cloned Id, but if
253 -- if the orig defn is a let-binding, and
254 -- the RHS of the let simplifies to an atom,
255 -- we just bind the variable to that atom, and
260 lookupId :: SimplEnv -> Id -> Eager ans OutArg
262 lookupId (SimplEnv _ _ _ in_id_env _ _) id
263 = case (lookupIdEnv in_id_env id) of
264 Just atom -> returnEager atom
265 Nothing -> returnEager (VarArg id)
272 -> OutArg{-Val args only, please-}
275 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
276 (in_id,occ_info) atom
278 LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
279 VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env
280 (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
281 --SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
283 new_in_id_env = addOneToIdEnv in_id_env in_id atom
285 new_out_id_env = case atom of
286 LitArg _ -> out_id_env
287 VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
290 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
291 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
294 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
296 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
298 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
300 new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
302 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
303 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
305 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
307 new_in_id_env = growIdEnvList in_id_env bindings
308 bindings = zipEqual "extendIdEnvWithClones"
309 [id | (id,_) <- in_binders]
313 %************************************************************************
315 \subsubsection{The @OutIdEnv@}
317 %************************************************************************
320 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
321 both locally-bound ones, and perhaps some imported ones too.
324 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
328 The "Id" part is just so that we can recover the domain of the mapping, which
329 IdEnvs don't allow directly.
331 The @BinderInfo@ tells about the occurrences of the @OutId@.
332 Anything that isn't in here should be assumed to occur many times.
333 We keep this info so we can modify it when something changes.
335 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
338 data RhsInfo = NoRhsInfo
339 | OtherLit [Literal] -- It ain't one of these
340 | OtherCon [Id] -- It ain't one of these
342 | InUnfolding SimplEnv -- Un-simplified unfolding
343 SimpleUnfolding -- (need to snag envts therefore)
345 | OutUnfolding CostCentre
346 SimpleUnfolding -- Already-simplified unfolding
348 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
349 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
351 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
353 = case lookupOutIdEnv env id of
354 Just (_,_,info) -> info
357 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
358 -> (OutId, BinderInfo, RhsInfo)
359 -> (OutId, BinderInfo, RhsInfo)
360 modifyOutEnvItem (id, occ, info1) (_, _, info2)
361 = case (info1, info2) of
362 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
363 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
364 (_, NoRhsInfo) -> (id,occ, info1)
365 other -> (id,occ, info2)
370 isEvaluated :: RhsInfo -> Bool
371 isEvaluated (OtherLit _) = True
372 isEvaluated (OtherCon _) = True
373 isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
374 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
375 isEvaluated other = False
381 mkSimplUnfoldingGuidance chkr out_id rhs
382 = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
384 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
385 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
386 out_id occ_info rhs_info
387 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
389 new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
390 (out_id, occ_info, rhs_info)
395 modifyOccInfo out_id_env (uniq, new_occ)
396 = modifyIdEnv_Directly modify_fn out_id_env uniq
398 modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
400 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
401 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
403 new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
404 modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
409 %************************************************************************
411 \subsubsection{The @ConAppMap@ type}
413 %************************************************************************
415 The @ConAppMap@ maps applications of constructors (to value atoms)
416 back to an association list that says "if the constructor was applied
417 to one of these lists-of-Types, then this OutId is your man (in a
418 non-gender-specific sense)". I.e., this is a reversed mapping for
419 (part of) the main OutIdEnv
422 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
425 = UCA OutId -- data constructor
426 [OutArg] -- *value* arguments; see use below
430 nullConApps = emptyFM
432 extendConApps con_apps id (Con con args)
433 = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
435 val_args = filter isValArg args -- Literals and Ids
436 ty_args = [ty | TyArg ty <- args] -- Just types
438 extendConApps con_apps id other_rhs = con_apps
442 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
443 = case lookupFM con_apps (UCA con val_args) of
446 Just assocs -> case [id | (tys, id) <- assocs,
447 and (zipWith eqTy tys ty_args)]
452 val_args = filter isValArg args -- Literals and Ids
453 ty_args = [ty | TyArg ty <- args] -- Just types
457 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
458 for nullary constructors, but now we only do constructor re-use in
459 let-bindings the special case isn't necessary any more.
462 = -- Don't re-use nullary constructors; it's a waste. Consider
470 -- Here the False in the second case will get replace by "a", hardly
476 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
477 it, so we can use it for a @FiniteMap@ key.
480 instance Eq UnfoldConApp where
481 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
482 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
484 instance Ord UnfoldConApp where
485 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
486 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
487 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
488 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
489 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
491 instance Ord3 UnfoldConApp where
494 cmp_app (UCA c1 as1) (UCA c2 as2)
495 = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
497 -- ToDo: make an "instance Ord3 CoreArg"???
499 cmp_arg (VarArg x) (VarArg y) = x `cmp` y
500 cmp_arg (LitArg x) (LitArg y) = x `cmp` y
501 cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
502 cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
504 | tag x _LT_ tag y = LT_
507 tag (VarArg _) = ILIT(1)
508 tag (LitArg _) = ILIT(2)
509 tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
510 tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
517 ============================ OLD ================================
518 This version was used when we use the *simplified* RHS of a
519 let as the thing's unfolding. The has the nasty property described
520 in the following comments. Much worse, it can fail to terminate
521 on recursive things. Consider
523 letrec f = \x -> let z = f x' in ...
530 If we bind n to its *simplified* RHS, we then *re-simplify* it when
531 we inline n. Then we may well inline f; and then the same thing
535 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
536 of a new binding. There is a horrid case we have to take care about,
537 due to Andr\'e Santos:
539 type Array_type b = Array Int b;
540 type Descr_type = (Int,Int);
542 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
543 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
547 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
548 f_aareorder a_index a_ar=
550 f_aareorder' a_i= a_ar ! (a_index ! a_i)
551 } in tabulate f_aareorder' (bounds a_ar);
552 r_index=tabulate ((+) 1) (1,1);
553 arr = listArray (1,1) a_xs;
554 arg = f_aareorder r_index arr
557 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
559 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
560 in tabulate f_aareorder' (bounds arr)
562 Note that r_index is not inlined, because it was bound to a_index which
563 occurs inside a lambda.
565 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
566 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
567 analyse it, we won't spot the inside-lambda property of r_index, so r_index
568 will get inlined inside the lambda. AARGH.
570 Solution: when we occurrence-analyse the new RHS we have to go back
571 and modify the info recorded in the UnfoldEnv for the free vars
572 of the RHS. In the example we'd go back and record that r_index is now used
576 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
577 extendEnvGivenNewRhs env out_id rhs
578 = extendEnvGivenBinding env noBinderInfo out_id rhs
580 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
581 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
583 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
585 new_out_id_env = case guidance of
586 UnfoldNever -> out_id_env -- No new stuff to put in
587 other -> out_id_env_with_unfolding
589 new_con_apps = _scc_ "eegnr.conapps"
590 extendConApps con_apps out_id rhs
592 -- Modify the occ info for rhs's interesting free variables.
593 out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
594 foldl modifyOccInfo env1 full_fv_occ_info
595 -- NB: full_fv_occ_info *combines* the occurrence of the current binder
596 -- with the occurrences of its RHS's free variables. That's to take
598 -- let a = \x -> BIG in
600 -- in ...b...b...b...
601 -- Here "a" occurs exactly once. "b" simplifies to a small value.
602 -- So "b" will be inlined at each call site, and there's a good chance
603 -- that "a" will too. So we'd better modify "a"s occurrence info to
604 -- record the fact that it can now occur many times by virtue that "b" can.
606 full_fv_occ_info = _scc_ "eegnr.full_fv"
607 [ (uniq, fv_occ `andBinderInfo` occ_info)
608 | (uniq, fv_occ) <- ufmToList fv_occ_info
611 -- Add an unfolding and rhs_info for the new Id.
612 -- If the out_id is already in the OutIdEnv (which can happen if
613 -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
614 -- then just replace the unfolding, leaving occurrence info alone.
615 env1 = _scc_ "eegnr.modify_out"
616 addToUFM_C modifyOutEnvItem out_id_env out_id
617 (out_id, occ_info, rhs_info)
619 -- Occurrence-analyse the RHS
620 -- The "interesting" free variables we want occurrence info for are those
621 -- in the OutIdEnv that have only a single occurrence right now.
622 (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
623 occurAnalyseExpr is_interesting rhs
625 is_interesting v = _scc_ "eegnr.mkidset"
626 case lookupIdEnv out_id_env v of
627 Just (_, OneOcc _ _ _ _ _, _) -> True
630 -- Compute unfolding details
631 rhs_info = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
632 form_summary = _scc_ "eegnr.form_sum"
634 guidance = _scc_ "eegnr.guidance"
635 mkSimplUnfoldingGuidance chkr out_id rhs
637 -- Compute cost centre for thing
638 unf_cc | noCostCentreAttached expr_cc = encl_cc
639 | otherwise = expr_cc
641 expr_cc = coreExprCc rhs
647 ========================== OLD [removed SLPJ March 97] ====================
649 I removed the attempt to inline recursive bindings when I discovered
650 a program that made the simplifier loop (nofib/spectral/hartel/typecheck/Main.hs)
652 The nasty case is this:
654 letrec f = \x -> let z = f x' in ...
661 If we bind n to its *simplified* RHS, we then *re-simplify* it when we
662 inline n. Then we may well inline f; and then the same thing happens
667 We need to be pretty careful when extending
668 the environment with RHS info in recursive groups.
670 Here's a nasty example:
678 Here, r occurs exactly once, so we may reasonably inline r in t's RHS.
679 But the pre-simplified t's rhs is an atom, r, so we may also decide to
680 inline t everywhere. But if we do *both* these reasonable things we get
688 Bad news! (f x) is duplicated! (The t in the body doesn't get
689 inlined because by the time the recursive group is done we see that
690 t's RHS isn't an atom.)
692 Our solution is this:
693 (a) we inline un-simplified RHSs, and then simplify
694 them in a clone-only environment.
695 (b) we inline only variables and values
701 x = ...t... ==> x = ...r...
705 Now t is dead, and we're home.
707 Most silly x=y bindings in recursive group will go away. But not all:
712 Here, we can't inline x because it's in an argument position. so we'll just replace
713 with a clone of y. Instead we'll probably inline y (a small value) to give
718 which is OK if not clever.
724 extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
725 (out_id, ((_,occ_info), old_rhs))
726 = case (form_summary, guidance) of
727 (_, UnfoldNever) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in
728 (ValueForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
729 (VarForm, _) -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
730 other -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- Not a value or variable
732 -- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
735 new_out_id_env = case (form_summary, guidance) of
736 (_, UnfoldNever) -> out_id_env -- No new stuff to put in
737 (ValueForm, _) -> out_id_env_with_unfolding
738 (VarForm, _) -> out_id_env_with_unfolding
739 other -> out_id_env -- Not a value or variable
741 -- If there is an unfolding, we add rhs-info for out_id,
742 -- No need to modify occ info because RHS is pre-simplification
743 out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id
744 (out_id, occ_info, rhs_info)
746 -- Compute unfolding details
747 -- Note that we use the "old" environment, that just has clones of the rec-bound vars,
748 -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once.
749 -- Only if the thing is still small enough next time round will we inline again.
750 rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
751 form_summary = mkFormSummary old_rhs
752 guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)