2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplEnv]{Environment stuff for the simplifier}
7 #include "HsVersions.h"
11 pprSimplEnv, -- debugging only
13 replaceInEnvs, nullInEnvs,
15 extendTyEnv, extendTyEnvList,
18 extendIdEnvWithAtom, extendIdEnvWithAtomList,
19 extendIdEnvWithInlining,
20 extendIdEnvWithClone, extendIdEnvWithClones,
23 extendUnfoldEnvGivenRhs,
24 extendUnfoldEnvGivenFormDetails,
25 extendUnfoldEnvGivenConstructor,
27 lookupUnfolding, filterUnfoldEnvForInlines,
29 getSwitchChecker, switchIsSet,
35 SimplEnv, EnclosingCcDetails(..),
36 InIdEnv(..), IdVal(..), InTypeEnv(..),
37 UnfoldEnv, UnfoldItem, UnfoldConApp,
39 InId(..), InBinder(..), InBinding(..), InType(..),
40 OutId(..), OutBinder(..), OutBinding(..), OutType(..),
42 InExpr(..), InAlts(..), InDefault(..), InArg(..),
43 OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
45 -- and to make the interface self-sufficient...
50 import SmplLoop -- breaks the MagicUFs / SimplEnv loop
52 import BinderInfo ( BinderInfo{-instances-} )
53 import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
55 import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
56 calcUnfoldingGuidance, UnfoldingGuidance(..),
57 mkFormSummary, FormSummary
59 import FiniteMap -- lots of things
60 import Id ( idType, getIdUnfolding, getIdStrictness,
62 nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
63 addOneToIdEnv, modifyIdEnv,
64 IdEnv(..), IdSet(..), GenId )
65 import IdInfo ( StrictnessInfo )
66 import Literal ( isNoRepLit, Literal{-instances-} )
67 import Outputable ( isLocallyDefined, Outputable(..){-instances-} )
68 import PprCore -- various instances
69 import PprStyle ( PprStyle(..) )
70 import PprType ( GenType, GenTyVar )
72 import Type ( getAppDataTyCon, applyTypeEnvToTy )
73 import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
75 TyVarEnv(..), GenTyVar{-instance Eq-}
77 import Unique ( Unique{-instance Outputable-} )
78 import UniqSet -- lots of things
79 import Usage ( UVar(..), GenUsage{-instances-} )
80 import Util ( zipEqual, panic, assertPanic )
82 type TypeEnv = TyVarEnv Type
83 addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)"
84 bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)"
85 cmpType = panic "cmpType (SimplEnv)"
86 exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
87 lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)"
88 manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)"
89 occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)"
90 oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
91 oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
92 simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
93 uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)"
94 ufmToList = panic "ufmToList (SimplEnv)"
97 %************************************************************************
99 \subsection[Simplify-types]{Type declarations}
101 %************************************************************************
104 %************************************************************************
106 \subsubsection{The @SimplEnv@ type}
108 %************************************************************************
111 INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
112 this? WDP 94/06) This allows us to neglect keeping everything paired
113 with its static environment.
115 The environment contains bindings for all
117 {\em locally-defined}
120 For such things, any unfolding is found in the environment, not in the
121 Id. Unfoldings in the Id itself are used only for imported things
122 (otherwise we get trouble because we have to simplify the unfoldings
123 inside the Ids, etc.).
130 EnclosingCcDetails -- the enclosing cost-centre (when profiling)
132 InTypeEnv -- For cloning types
133 -- Domain is all in-scope type variables
141 -- (Could omit the exported top-level guys,
142 -- since their names mustn't change; and ditto
143 -- the non-exported top-level guys which you
144 -- don't want to macro-expand, since their
145 -- names need not change.)
149 UnfoldEnv -- Domain is any *OutIds*, including imports
150 -- where we know something more than the
151 -- interface file tells about their value (see
154 nullSimplEnv :: SwitchChecker -> SimplEnv
157 = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
159 pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
161 ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
162 ppSP, ppStr "** Id Env ** ?????????",
163 -- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
164 ppSP, ppStr "** Unfold Env **",
165 ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
168 pp_id_entry (v, idval)
169 = ppCat [ppr PprDebug v, ppStr "=>",
171 InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
172 ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
175 pp_uf_entry (UnfoldItem v form encl_cc)
176 = ppCat [ppr PprDebug v, ppStr "=>",
178 NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
179 LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
180 OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
181 [ppr PprDebug l | l <- ls]]
182 ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
183 OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
184 [ppr PprDebug c | c <- cs]]
185 GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
186 ppr PprDebug g, ppr PprDebug e]
187 MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
191 %************************************************************************
193 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
195 %************************************************************************
197 The unfoldings for imported things are mostly kept within the Id
198 itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For
199 example, suppose \tr{x} is imported, and we have
204 Then within \tr{<body>}, we know that \tr{x} is a pair with components
208 type InIdEnv = IdEnv IdVal -- Maps InIds to their value
211 = InlineIt InIdEnv InTypeEnv InExpr
212 -- No binding of the Id is left;
213 -- You *have* to replace any occurences
214 -- of the id with this expression.
215 -- Rather like a macro, really
216 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
217 -- name caputure. Consider:
222 -- If x gets an InlineIt, we must remember
223 -- the correct binding for y.
225 | ItsAnAtom OutArg -- Used either (a) to record the cloned Id
226 -- or (b) if the orig defn is a let-binding, and
227 -- the RHS of the let simplifies to an atom,
228 -- we just bind the variable to that atom, and
232 %************************************************************************
234 \subsubsection{The @UnfoldEnv@ type}
236 %************************************************************************
238 The @UnfoldEnv@ contains information about the value of some of the
239 in-scope identifiers. It obeys the following invariant:
241 If the @UnfoldEnv@ contains information, it is safe to use it!
243 In particular, if the @UnfoldEnv@ contains details of an unfolding of
244 an Id, then it's safe to use the unfolding. If, for example, the Id
245 is used many times, then its unfolding won't be put in the UnfoldEnv
248 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
249 because (a)~it's small, and (b)~we need to search its {\em range} as
253 data UnfoldItem -- a glorified triple...
254 = UnfoldItem OutId -- key: used in lookForConstructor
255 UnfoldingDetails -- for that Id
256 EnclosingCcDetails -- so that if we do an unfolding,
257 -- we can "wrap" it in the CC
258 -- that was in force.
260 data UnfoldConApp -- yet another glorified triple
261 = UCA OutId -- same fields as ConForm
264 data UnfoldEnv -- yup, a glorified triple...
265 = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
266 IdSet -- The Ids in the domain of the env
267 -- which have details (GenForm True ...)
268 -- i.e., they claim they are duplicatable.
269 -- These are the ones we have to worry
270 -- about when adding new items to the
272 (FiniteMap UnfoldConApp OutId)
273 -- Maps applications of constructors (to
274 -- types & atoms) back to OutIds that are
275 -- bound to them; i.e., this is a reversed
276 -- mapping for (part of) the main IdEnv
279 null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
282 The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
283 be small, because it contains bindings only for those things whose
284 form or unfolding is known. Basically it maps @Id@ to their
285 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
286 need to search it associatively, to look for @Id@s which have a given
289 We implement it with @IdEnvs@, possibly overkill, but sometimes these
290 things silently grow quite big.... Here are some local functions used
291 elsewhere in the module:
294 grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
295 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
296 lookup_unfold_env_encl_cc
297 :: UnfoldEnv -> OutId -> EnclosingCcDetails
299 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
301 grow_unfold_env (UFE u_env interesting_ids con_apps) id
302 uf_details@(GenForm True _ _ _) encl_cc
303 -- Only interested in Ids which have a "dangerous" unfolding; that is
304 -- one that claims to have a single occurrence.
305 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
306 (addOneToUniqSet interesting_ids id)
309 grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
310 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
317 -> case (lookupFM con_apps entry) of
318 Just _ -> con_apps -- unchanged; we hang onto what we have
319 Nothing -> addToFM con_apps entry id
321 entry = UCA con vargs
323 not_a_constructor -> con_apps -- unchanged
325 addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
326 = ASSERT(not (any constructor_form_in_those extra_items))
327 -- otherwise, we'd need to change con_apps
328 UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
330 constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
331 constructor_form_in_those _ = False
333 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
335 get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
337 foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
338 = UFE (foldr fun u_env stuff) interesting_ids con_apps
340 lookup_unfold_env (UFE u_env _ _) id
341 = case (lookupIdEnv u_env id) of
342 Nothing -> NoUnfoldingDetails
343 Just (UnfoldItem _ uf _) -> uf
345 lookup_unfold_env_encl_cc (UFE u_env _ _) id
346 = case (lookupIdEnv u_env id) of
347 Nothing -> NoEnclosingCcDetails
348 Just (UnfoldItem _ _ encl_cc) -> encl_cc
350 lookup_conapp (UFE _ _ con_apps) con args
351 = lookupFM con_apps (UCA con args)
353 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
354 = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
356 -- If the current binding claims to be a "unique" one, then
358 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
360 modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
361 = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
364 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
365 it, so we can use it for a @FiniteMap@ key.
367 instance Eq UnfoldConApp where
368 a == b = case cmp_app a b of { EQ_ -> True; _ -> False }
369 a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
371 instance Ord UnfoldConApp where
372 a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
373 a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
374 a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
375 a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
376 _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
378 instance Ord3 UnfoldConApp where
381 cmp_app (UCA c1 as1) (UCA c2 as2)
382 = case (c1 `cmp` c2) of
385 _ -> cmp_lists cmp_atom as1 as2
387 cmp_lists cmp_item [] [] = EQ_
388 cmp_lists cmp_item (x:xs) [] = GT_
389 cmp_lists cmp_item [] (y:ys) = LT_
390 cmp_lists cmp_item (x:xs) (y:ys)
391 = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
393 cmp_atom (VarArg x) (VarArg y) = x `cmp` y
394 cmp_atom (VarArg _) _ = LT_
395 cmp_atom (LitArg x) (LitArg y)
396 = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
397 cmp_atom (LitArg _) _ = GT_
400 %************************************************************************
402 \subsubsection{The @EnclosingCcDetails@ type}
404 %************************************************************************
407 data EnclosingCcDetails
408 = NoEnclosingCcDetails
409 | EnclosingCC CostCentre
412 %************************************************************************
414 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
416 %************************************************************************
419 type InId = Id -- Not yet cloned
420 type InBinder = (InId, BinderInfo)
421 type InType = Type -- Ditto
422 type InBinding = SimplifiableCoreBinding
423 type InExpr = SimplifiableCoreExpr
424 type InAlts = SimplifiableCoreCaseAlts
425 type InDefault = SimplifiableCoreCaseDefault
426 type InArg = SimplifiableCoreArg
428 type OutId = Id -- Cloned
430 type OutType = Type -- Cloned
431 type OutBinding = CoreBinding
432 type OutExpr = CoreExpr
433 type OutAlts = CoreCaseAlts
434 type OutDefault = CoreCaseDefault
435 type OutArg = CoreArg
440 type SwitchChecker = SimplifierSwitch -> SwitchResult
443 %************************************************************************
445 \subsection{@SimplEnv@ handling}
447 %************************************************************************
449 %************************************************************************
451 \subsubsection{Command-line switches}
453 %************************************************************************
456 getSwitchChecker :: SimplEnv -> SwitchChecker
457 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
459 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
460 switchIsSet (SimplEnv chkr _ _ _ _) switch
461 = switchIsOn chkr switch
464 %************************************************************************
466 \subsubsection{The ``enclosing cost-centre''}
468 %************************************************************************
471 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
473 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
474 = SimplEnv chkr encl_cc ty_env id_env unfold_env
477 %************************************************************************
479 \subsubsection{The @TypeEnv@ part}
481 %************************************************************************
484 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
486 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
487 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
488 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
490 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
492 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
493 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
494 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
496 new_ty_env = growTyVarEnvList ty_env pairs
498 simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
499 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
502 @replaceInEnvs@ is used to install saved type and id envs
503 when pulling an un-simplified expression out of the environment, which
504 was saved with its environments.
507 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
509 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
511 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
512 (new_ty_env, new_id_env)
513 = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
516 %************************************************************************
518 \subsubsection{The ``Id env'' part}
520 %************************************************************************
525 -> InBinder -> OutArg
528 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
529 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
531 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
533 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
534 (in_id, occ_info) atom@(VarArg out_id)
535 = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
537 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
539 new_unfold_env = modify_unfold_env
541 (modifyItem ok_to_dup occ_info)
543 -- Modify binding for in_id
544 -- NO! modify out_id, because its the info on the
545 -- atom that interest's us.
547 ok_to_dup = switchIsOn chkr SimplOkToDupCode
549 extendIdEnvWithAtomList
551 -> [(InBinder, OutArg)]
553 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
555 extendIdEnvWithInlining
556 :: SimplEnv -- The Env to modify
557 -> SimplEnv -- The Env to record in the inlining. Usually the
558 -- same as the previous one, except in the recursive case
559 -> InBinder -> InExpr
562 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
563 ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
566 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
568 new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
572 -> InBinder -- Old binder; binderinfo ignored
573 -> OutId -- Its new clone, as an Id
576 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
578 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
580 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
582 extendIdEnvWithClones -- Like extendIdEnvWithClone
588 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
590 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
592 new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
593 in_ids = [id | (id,_) <- in_binders]
594 out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
596 lookupId :: SimplEnv -> Id -> Maybe IdVal
598 lookupId (SimplEnv _ _ _ id_env _) id
600 = lookupIdEnv id_env id
602 = case (lookupIdEnv id_env id) of
604 xxx -> --false!: ASSERT(not (isLocallyDefined id))
609 %************************************************************************
611 \subsubsection{The @UnfoldEnv@}
613 %************************************************************************
616 extendUnfoldEnvGivenFormDetails
622 extendUnfoldEnvGivenFormDetails
623 env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
626 NoUnfoldingDetails -> env
627 good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
629 new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
631 extendUnfoldEnvGivenConstructor -- specialised variant
633 -> OutId -- bind this to...
634 -> Id -> [OutId] -- "con <tys-to-be-invented> args"
637 extendUnfoldEnvGivenConstructor env var con args
639 -- conjure up the types to which the con should be applied
640 scrut_ty = idType var
641 (_, ty_args, _) = getAppDataTyCon scrut_ty
643 extendUnfoldEnvGivenFormDetails
644 env var (ConForm con (map VarArg args))
648 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
649 of a new binding. There is a horrid case we have to take care about,
650 due to Andr\'e Santos:
652 type Array_type b = Array Int b;
653 type Descr_type = (Int,Int);
655 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
656 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
660 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
661 f_aareorder a_index a_ar=
663 f_aareorder' a_i= a_ar ! (a_index ! a_i)
664 } in tabulate f_aareorder' (bounds a_ar);
665 r_index=tabulate ((+) 1) (1,1);
666 arr = listArray (1,1) a_xs;
667 arg = f_aareorder r_index arr
670 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
672 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
673 in tabulate f_aareorder' (bounds arr)
675 Note that r_index is not inlined, because it was bound to a_index which
676 occurs inside a lambda.
678 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
679 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
680 analyse it, we won't spot the inside-lambda property of r_index, so r_index
681 will get inlined inside the lambda. AARGH.
683 Solution: when we occurrence-analyse the new RHS we have to go back
684 and modify the info recorded in the UnfoldEnv for the free vars
685 of the RHS. In the example we'd go back and record that r_index is now used
689 extendUnfoldEnvGivenRhs
692 -> OutId -- Note: *must* be an "out" Id (post-cloning)
693 -> OutExpr -- Its rhs (*simplified*)
696 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
697 binder@(_,occ_info) out_id rhs
698 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
700 -- Occurrence-analyse the RHS
701 (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
703 interesting_fvs = get_interesting_ids unfold_env
705 -- Compute unfolding details
706 details = case rhs of
707 Var v -> panic "Vars already dealt with"
708 Lit lit | isNoRepLit lit -> LitForm lit
709 | otherwise -> panic "non-noRep Lits already dealt with"
711 Con con args -> ConForm con args
713 other -> mkGenForm ok_to_dup occ_info
714 (mkFormSummary (getIdStrictness out_id) rhs)
717 -- Compute resulting unfold env
718 new_unfold_env = case details of
719 NoUnfoldingDetails -> unfold_env
720 GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
723 -- Add unfolding to unfold env
724 unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
726 -- Modify unfoldings of free vars of rhs, based on their
727 -- occurrence info in the rhs [see notes above]
728 unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
730 modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
731 modify (u, occ_info) env
732 = case (lookupDirectlyUFM env u) of
733 Nothing -> env -- ToDo: can this happen?
734 Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
736 -- Compute unfolding guidance
737 guidance = if simplIdWantsToBeINLINEd out_id env
739 else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
741 bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
742 Nothing -> uNFOLDING_CREATION_THRESHOLD
745 ok_to_dup = switchIsOn chkr SimplOkToDupCode
746 || exprSmallEnoughToDup rhs
747 -- [Andy] added, Jun 95
749 {- Reinstated AJG Jun 95; This is needed
750 --example that does not (currently) work
751 --without this extention
764 Omitted SLPJ Feb 95; should, I claim, be unnecessary
765 -- is_really_small looks for things like f a b c
766 -- but making sure there are not *too* many arguments.
767 -- (This is brought to you by *ANDY* Magic Constants, Inc.)
769 = case collectArgs new_rhs of
770 (Var _, _, _, xs) -> length xs < 10
776 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
778 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
779 | not (isLocallyDefined var) -- Imported, so look inside the id
782 | otherwise -- Locally defined, so look in the envt.
783 -- There'll be nothing inside the Id.
784 = lookup_unfold_env unfold_env var
787 We need to remove any @GenForm@ bindings from the UnfoldEnv for
788 the RHS of an Id which has an INLINE pragma.
791 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
793 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
794 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
796 new_unfold_env = null_unfold_env
797 -- This version is really simple. INLINEd things are going to
798 -- be inlined wherever they are used, and then all the
799 -- UnfoldEnv stuff will take effect. Meanwhile, there isn't
800 -- much point in doing anything to the as-yet-un-INLINEd rhs.
802 -- Andy disagrees! Example:
803 -- all xs = foldr (&&) True xs
804 -- any p = all . map p {-# INLINE any #-}
806 -- Problem: any won't get deforested, and so if it's exported and
807 -- the importer doesn't use the inlining, (eg passes it as an arg)
808 -- then we won't get deforestation at all.
810 -- So he'd like not to filter the unfold env at all. But that's a disaster:
813 -- let f = \pq -> BIG
815 -- let g = \y -> f y y
817 -- in ...g...g...g...g...g...
819 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
820 -- and thence copied multiple times when g is inlined.
823 ======================
825 In @lookForConstructor@ we used (before Apr 94) to have a special case
826 for nullary constructors:
829 = -- Don't re-use nullary constructors; it's a waste. Consider
837 -- Here the False in the second case will get replace by "a", hardly
842 but now we only do constructor re-use in let-bindings the special
843 case isn't necessary any more.
846 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
847 = lookup_conapp unfold_env con args