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(..)
48 import SmplLoop -- breaks the MagicUFs / SimplEnv loop
50 import BinderInfo ( BinderInfo{-instances-} )
51 import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
52 import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
54 import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
55 calcUnfoldingGuidance, UnfoldingGuidance(..),
56 mkFormSummary, FormSummary
58 import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup )
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 ( bottomIsGuaranteed, StrictnessInfo )
66 import Literal ( isNoRepLit, Literal{-instances-} )
67 import Name ( isLocallyDefined )
68 import OccurAnal ( occurAnalyseExpr )
69 import Outputable ( Outputable(..){-instances-} )
70 import PprCore -- various instances
71 import PprStyle ( PprStyle(..) )
72 import PprType ( GenType, GenTyVar )
74 import Type ( eqTy, getAppDataTyCon, applyTypeEnvToTy )
75 import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
77 TyVarEnv(..), GenTyVar{-instance Eq-}
79 import Unique ( Unique{-instance Outputable-} )
80 import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList )
81 import UniqSet -- lots of things
82 import Usage ( UVar(..), GenUsage{-instances-} )
83 import Util ( zipEqual, panic, panic#, assertPanic )
85 type TypeEnv = TyVarEnv Type
86 cmpType = panic "cmpType (SimplEnv)"
87 oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
88 oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
89 simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
92 %************************************************************************
94 \subsection[Simplify-types]{Type declarations}
96 %************************************************************************
99 %************************************************************************
101 \subsubsection{The @SimplEnv@ type}
103 %************************************************************************
106 INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
107 this? WDP 94/06) This allows us to neglect keeping everything paired
108 with its static environment.
110 The environment contains bindings for all
112 {\em locally-defined}
115 For such things, any unfolding is found in the environment, not in the
116 Id. Unfoldings in the Id itself are used only for imported things
117 (otherwise we get trouble because we have to simplify the unfoldings
118 inside the Ids, etc.).
125 EnclosingCcDetails -- the enclosing cost-centre (when profiling)
127 InTypeEnv -- For cloning types
128 -- Domain is all in-scope type variables
136 -- (Could omit the exported top-level guys,
137 -- since their names mustn't change; and ditto
138 -- the non-exported top-level guys which you
139 -- don't want to macro-expand, since their
140 -- names need not change.)
144 UnfoldEnv -- Domain is any *OutIds*, including imports
145 -- where we know something more than the
146 -- interface file tells about their value (see
149 nullSimplEnv :: SwitchChecker -> SimplEnv
152 = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
154 pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
156 ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
157 ppSP, ppStr "** Id Env ** ?????????",
158 -- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
159 ppSP, ppStr "** Unfold Env **",
160 ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
163 pp_id_entry (v, idval)
164 = ppCat [ppr PprDebug v, ppStr "=>",
166 InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
167 ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
170 pp_uf_entry (UnfoldItem v form encl_cc)
171 = ppCat [ppr PprDebug v, ppStr "=>",
173 NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
174 LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
175 OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
176 [ppr PprDebug l | l <- ls]]
177 ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
178 OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
179 [ppr PprDebug c | c <- cs]]
180 GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
181 ppr PprDebug g, ppr PprDebug e]
182 MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
186 %************************************************************************
188 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
190 %************************************************************************
192 The unfoldings for imported things are mostly kept within the Id
193 itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For
194 example, suppose \tr{x} is imported, and we have
199 Then within \tr{<body>}, we know that \tr{x} is a pair with components
203 type InIdEnv = IdEnv IdVal -- Maps InIds to their value
206 = InlineIt InIdEnv InTypeEnv InExpr
207 -- No binding of the Id is left;
208 -- You *have* to replace any occurences
209 -- of the id with this expression.
210 -- Rather like a macro, really
211 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
212 -- name caputure. Consider:
217 -- If x gets an InlineIt, we must remember
218 -- the correct binding for y.
220 | ItsAnAtom OutArg -- Used either (a) to record the cloned Id
221 -- or (b) if the orig defn is a let-binding, and
222 -- the RHS of the let simplifies to an atom,
223 -- we just bind the variable to that atom, and
227 %************************************************************************
229 \subsubsection{The @UnfoldEnv@ type}
231 %************************************************************************
233 The @UnfoldEnv@ contains information about the value of some of the
234 in-scope identifiers. It obeys the following invariant:
236 If the @UnfoldEnv@ contains information, it is safe to use it!
238 In particular, if the @UnfoldEnv@ contains details of an unfolding of
239 an Id, then it's safe to use the unfolding. If, for example, the Id
240 is used many times, then its unfolding won't be put in the UnfoldEnv
243 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
244 because (a)~it's small, and (b)~we need to search its {\em range} as
248 data UnfoldItem -- a glorified triple...
249 = UnfoldItem OutId -- key: used in lookForConstructor
250 UnfoldingDetails -- for that Id
251 EnclosingCcDetails -- so that if we do an unfolding,
252 -- we can "wrap" it in the CC
253 -- that was in force.
255 data UnfoldConApp -- yet another glorified pair
256 = UCA OutId -- same fields as ConForm
259 data UnfoldEnv -- yup, a glorified triple...
260 = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
261 IdSet -- The Ids in the domain of the env
262 -- which have details (GenForm True ...)
263 -- i.e., they claim they are duplicatable.
264 -- These are the ones we have to worry
265 -- about when adding new items to the
267 (FiniteMap UnfoldConApp OutId)
268 -- Maps applications of constructors (to
269 -- types & atoms) back to OutIds that are
270 -- bound to them; i.e., this is a reversed
271 -- mapping for (part of) the main IdEnv
274 null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
277 The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
278 be small, because it contains bindings only for those things whose
279 form or unfolding is known. Basically it maps @Id@ to their
280 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
281 need to search it associatively, to look for @Id@s which have a given
284 We implement it with @IdEnvs@, possibly overkill, but sometimes these
285 things silently grow quite big.... Here are some local functions used
286 elsewhere in the module:
289 grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
290 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
291 lookup_unfold_env_encl_cc
292 :: UnfoldEnv -> OutId -> EnclosingCcDetails
294 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
296 grow_unfold_env (UFE u_env interesting_ids con_apps) id
297 uf_details@(GenForm True _ _ _) encl_cc
298 -- Only interested in Ids which have a "dangerous" unfolding; that is
299 -- one that claims to have a single occurrence.
300 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
301 (addOneToUniqSet interesting_ids id)
304 grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
305 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
312 -> case (lookupFM con_apps entry) of
313 Just _ -> con_apps -- unchanged; we hang onto what we have
314 Nothing -> addToFM con_apps entry id
318 not_a_constructor -> con_apps -- unchanged
320 addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
321 = ASSERT(not (any constructor_form_in_those extra_items))
322 -- otherwise, we'd need to change con_apps
323 UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
325 constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
326 constructor_form_in_those _ = False
328 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
330 get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
332 foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
333 = UFE (foldr fun u_env stuff) interesting_ids con_apps
335 lookup_unfold_env (UFE u_env _ _) id
336 = case (lookupIdEnv u_env id) of
337 Nothing -> NoUnfoldingDetails
338 Just (UnfoldItem _ uf _) -> uf
340 lookup_unfold_env_encl_cc (UFE u_env _ _) id
341 = case (lookupIdEnv u_env id) of
342 Nothing -> NoEnclosingCcDetails
343 Just (UnfoldItem _ _ encl_cc) -> encl_cc
345 lookup_conapp (UFE _ _ con_apps) con args
346 = lookupFM con_apps (UCA con args)
348 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
349 = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
351 -- If the current binding claims to be a "unique" one, then
353 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
355 modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
356 = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
359 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
360 it, so we can use it for a @FiniteMap@ key.
362 instance Eq UnfoldConApp where
363 a == b = case cmp_app a b of { EQ_ -> True; _ -> False }
364 a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
366 instance Ord UnfoldConApp where
367 a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
368 a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
369 a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
370 a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
371 _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
373 instance Ord3 UnfoldConApp where
376 cmp_app (UCA c1 as1) (UCA c2 as2)
377 = case (c1 `cmp` c2) of
380 _ -> cmp_lists cmp_arg as1 as2
382 cmp_lists cmp_item [] [] = EQ_
383 cmp_lists cmp_item (x:xs) [] = GT_
384 cmp_lists cmp_item [] (y:ys) = LT_
385 cmp_lists cmp_item (x:xs) (y:ys)
386 = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
388 -- ToDo: make an "instance Ord3 CoreArg"???
390 cmp_arg (VarArg x) (VarArg y) = x `cmp` y
391 cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
392 cmp_arg (TyArg x) (TyArg y) = if x `eqTy` y then EQ_ else panic# "SimplEnv.cmp_app:TyArgs"
393 cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
395 | tag x _LT_ tag y = LT_
398 tag (VarArg _) = ILIT(1)
399 tag (LitArg _) = ILIT(2)
400 tag (TyArg _) = ILIT(3)
401 tag (UsageArg _) = ILIT(4)
404 %************************************************************************
406 \subsubsection{The @EnclosingCcDetails@ type}
408 %************************************************************************
411 data EnclosingCcDetails
412 = NoEnclosingCcDetails
413 | EnclosingCC CostCentre
416 %************************************************************************
418 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
420 %************************************************************************
423 type InId = Id -- Not yet cloned
424 type InBinder = (InId, BinderInfo)
425 type InType = Type -- Ditto
426 type InBinding = SimplifiableCoreBinding
427 type InExpr = SimplifiableCoreExpr
428 type InAlts = SimplifiableCoreCaseAlts
429 type InDefault = SimplifiableCoreCaseDefault
430 type InArg = SimplifiableCoreArg
432 type OutId = Id -- Cloned
434 type OutType = Type -- Cloned
435 type OutBinding = CoreBinding
436 type OutExpr = CoreExpr
437 type OutAlts = CoreCaseAlts
438 type OutDefault = CoreCaseDefault
439 type OutArg = CoreArg
444 type SwitchChecker = SimplifierSwitch -> SwitchResult
447 %************************************************************************
449 \subsection{@SimplEnv@ handling}
451 %************************************************************************
453 %************************************************************************
455 \subsubsection{Command-line switches}
457 %************************************************************************
460 getSwitchChecker :: SimplEnv -> SwitchChecker
461 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
463 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
464 switchIsSet (SimplEnv chkr _ _ _ _) switch
465 = switchIsOn chkr switch
468 %************************************************************************
470 \subsubsection{The ``enclosing cost-centre''}
472 %************************************************************************
475 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
477 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
478 = SimplEnv chkr encl_cc ty_env id_env unfold_env
481 %************************************************************************
483 \subsubsection{The @TypeEnv@ part}
485 %************************************************************************
488 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
490 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
491 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
492 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
494 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
496 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
497 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
498 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
500 new_ty_env = growTyVarEnvList ty_env pairs
502 simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
503 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
506 @replaceInEnvs@ is used to install saved type and id envs
507 when pulling an un-simplified expression out of the environment, which
508 was saved with its environments.
511 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
513 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
515 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
516 (new_ty_env, new_id_env)
517 = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
520 %************************************************************************
522 \subsubsection{The ``Id env'' part}
524 %************************************************************************
529 -> InBinder -> OutArg{-Val args only, please-}
532 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
533 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
535 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
537 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
538 (in_id, occ_info) atom@(VarArg out_id)
539 = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
541 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
543 new_unfold_env = modify_unfold_env
545 (modifyItem ok_to_dup occ_info)
547 -- Modify binding for in_id
548 -- NO! modify out_id, because its the info on the
549 -- atom that interest's us.
551 ok_to_dup = switchIsOn chkr SimplOkToDupCode
554 extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
557 extendIdEnvWithAtomList
559 -> [(InBinder, OutArg)]
561 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
563 extendIdEnvWithInlining
564 :: SimplEnv -- The Env to modify
565 -> SimplEnv -- The Env to record in the inlining. Usually the
566 -- same as the previous one, except in the recursive case
567 -> InBinder -> InExpr
570 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
571 ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
574 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
576 new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
580 -> InBinder -- Old binder; binderinfo ignored
581 -> OutId -- Its new clone, as an Id
584 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
586 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
588 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
590 extendIdEnvWithClones -- Like extendIdEnvWithClone
596 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
598 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
600 new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals)
601 in_ids = [id | (id,_) <- in_binders]
602 out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
604 lookupId :: SimplEnv -> Id -> Maybe IdVal
606 lookupId (SimplEnv _ _ _ id_env _) id
608 = lookupIdEnv id_env id
610 = case (lookupIdEnv id_env id) of
612 xxx -> --false!: ASSERT(not (isLocallyDefined id))
617 %************************************************************************
619 \subsubsection{The @UnfoldEnv@}
621 %************************************************************************
624 extendUnfoldEnvGivenFormDetails
630 extendUnfoldEnvGivenFormDetails
631 env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
634 NoUnfoldingDetails -> env
635 good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
637 new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
639 extendUnfoldEnvGivenConstructor -- specialised variant
641 -> OutId -- bind this to...
642 -> Id -> [OutId] -- "con <tys-to-be-invented> args"
645 extendUnfoldEnvGivenConstructor env var con args
647 -- conjure up the types to which the con should be applied
648 scrut_ty = idType var
649 (_, ty_args, _) = getAppDataTyCon scrut_ty
651 extendUnfoldEnvGivenFormDetails
652 env var (ConForm con (map VarArg args))
656 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
657 of a new binding. There is a horrid case we have to take care about,
658 due to Andr\'e Santos:
660 type Array_type b = Array Int b;
661 type Descr_type = (Int,Int);
663 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
664 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
668 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
669 f_aareorder a_index a_ar=
671 f_aareorder' a_i= a_ar ! (a_index ! a_i)
672 } in tabulate f_aareorder' (bounds a_ar);
673 r_index=tabulate ((+) 1) (1,1);
674 arr = listArray (1,1) a_xs;
675 arg = f_aareorder r_index arr
678 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
680 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
681 in tabulate f_aareorder' (bounds arr)
683 Note that r_index is not inlined, because it was bound to a_index which
684 occurs inside a lambda.
686 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
687 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
688 analyse it, we won't spot the inside-lambda property of r_index, so r_index
689 will get inlined inside the lambda. AARGH.
691 Solution: when we occurrence-analyse the new RHS we have to go back
692 and modify the info recorded in the UnfoldEnv for the free vars
693 of the RHS. In the example we'd go back and record that r_index is now used
697 extendUnfoldEnvGivenRhs
700 -> OutId -- Note: *must* be an "out" Id (post-cloning)
701 -> OutExpr -- Its rhs (*simplified*)
704 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
705 binder@(_,occ_info) out_id rhs
706 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
708 -- Occurrence-analyse the RHS
709 (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
711 interesting_fvs = get_interesting_ids unfold_env
713 -- Compute unfolding details
714 details = case rhs of
715 Var v -> panic "Vars already dealt with"
716 Lit lit | isNoRepLit lit -> LitForm lit
717 | otherwise -> panic "non-noRep Lits already dealt with"
719 Con con args -> ConForm con args
721 other -> mkGenForm ok_to_dup occ_info
722 (mkFormSummary (getIdStrictness out_id) rhs)
725 -- Compute resulting unfold env
726 new_unfold_env = case details of
727 NoUnfoldingDetails -> unfold_env
728 GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
731 -- Add unfolding to unfold env
732 unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
734 -- Modify unfoldings of free vars of rhs, based on their
735 -- occurrence info in the rhs [see notes above]
736 unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
738 modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
739 modify (u, occ_info) env
740 = case (lookupUFM_Directly env u) of
741 Nothing -> env -- ToDo: can this happen?
742 Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
744 -- Compute unfolding guidance
745 guidance = if simplIdWantsToBeINLINEd out_id env
747 else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
749 bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
750 Nothing -> uNFOLDING_CREATION_THRESHOLD
753 ok_to_dup = switchIsOn chkr SimplOkToDupCode
754 || exprSmallEnoughToDup rhs
755 -- [Andy] added, Jun 95
757 {- Reinstated AJG Jun 95; This is needed
758 --example that does not (currently) work
759 --without this extention
772 Omitted SLPJ Feb 95; should, I claim, be unnecessary
773 -- is_really_small looks for things like f a b c
774 -- but making sure there are not *too* many arguments.
775 -- (This is brought to you by *ANDY* Magic Constants, Inc.)
777 = case collectArgs new_rhs of
778 (Var _, _, _, xs) -> length xs < 10
784 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
786 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
787 | not (isLocallyDefined var) -- Imported, so look inside the id
790 | otherwise -- Locally defined, so look in the envt.
791 -- There'll be nothing inside the Id.
792 = lookup_unfold_env unfold_env var
795 We need to remove any @GenForm@ bindings from the UnfoldEnv for
796 the RHS of an Id which has an INLINE pragma.
799 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
801 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
802 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
804 new_unfold_env = null_unfold_env
805 -- This version is really simple. INLINEd things are going to
806 -- be inlined wherever they are used, and then all the
807 -- UnfoldEnv stuff will take effect. Meanwhile, there isn't
808 -- much point in doing anything to the as-yet-un-INLINEd rhs.
810 -- Andy disagrees! Example:
811 -- all xs = foldr (&&) True xs
812 -- any p = all . map p {-# INLINE any #-}
814 -- Problem: any won't get deforested, and so if it's exported and
815 -- the importer doesn't use the inlining, (eg passes it as an arg)
816 -- then we won't get deforestation at all.
818 -- So he'd like not to filter the unfold env at all. But that's a disaster:
821 -- let f = \pq -> BIG
823 -- let g = \y -> f y y
825 -- in ...g...g...g...g...g...
827 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
828 -- and thence copied multiple times when g is inlined.
831 ======================
833 In @lookForConstructor@ we used (before Apr 94) to have a special case
834 for nullary constructors:
837 = -- Don't re-use nullary constructors; it's a waste. Consider
845 -- Here the False in the second case will get replace by "a", hardly
850 but now we only do constructor re-use in let-bindings the special
851 case isn't necessary any more.
854 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
855 = lookup_conapp unfold_env con args