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 )
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 ( 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, assertPanic )
85 type TypeEnv = TyVarEnv Type
86 cmpType = panic "cmpType (SimplEnv)"
87 exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
88 oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
89 oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
90 simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
93 %************************************************************************
95 \subsection[Simplify-types]{Type declarations}
97 %************************************************************************
100 %************************************************************************
102 \subsubsection{The @SimplEnv@ type}
104 %************************************************************************
107 INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
108 this? WDP 94/06) This allows us to neglect keeping everything paired
109 with its static environment.
111 The environment contains bindings for all
113 {\em locally-defined}
116 For such things, any unfolding is found in the environment, not in the
117 Id. Unfoldings in the Id itself are used only for imported things
118 (otherwise we get trouble because we have to simplify the unfoldings
119 inside the Ids, etc.).
126 EnclosingCcDetails -- the enclosing cost-centre (when profiling)
128 InTypeEnv -- For cloning types
129 -- Domain is all in-scope type variables
137 -- (Could omit the exported top-level guys,
138 -- since their names mustn't change; and ditto
139 -- the non-exported top-level guys which you
140 -- don't want to macro-expand, since their
141 -- names need not change.)
145 UnfoldEnv -- Domain is any *OutIds*, including imports
146 -- where we know something more than the
147 -- interface file tells about their value (see
150 nullSimplEnv :: SwitchChecker -> SimplEnv
153 = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env
155 pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _))
157 ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env,
158 ppSP, ppStr "** Id Env ** ?????????",
159 -- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ],
160 ppSP, ppStr "** Unfold Env **",
161 ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ]
164 pp_id_entry (v, idval)
165 = ppCat [ppr PprDebug v, ppStr "=>",
167 InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e]
168 ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a]
171 pp_uf_entry (UnfoldItem v form encl_cc)
172 = ppCat [ppr PprDebug v, ppStr "=>",
174 NoUnfoldingDetails -> ppStr "NoUnfoldingDetails"
175 LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l]
176 OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
177 [ppr PprDebug l | l <- ls]]
178 ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a]
179 OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
180 [ppr PprDebug c | c <- cs]]
181 GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w,
182 ppr PprDebug g, ppr PprDebug e]
183 MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
187 %************************************************************************
189 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
191 %************************************************************************
193 The unfoldings for imported things are mostly kept within the Id
194 itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For
195 example, suppose \tr{x} is imported, and we have
200 Then within \tr{<body>}, we know that \tr{x} is a pair with components
204 type InIdEnv = IdEnv IdVal -- Maps InIds to their value
207 = InlineIt InIdEnv InTypeEnv InExpr
208 -- No binding of the Id is left;
209 -- You *have* to replace any occurences
210 -- of the id with this expression.
211 -- Rather like a macro, really
212 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
213 -- name caputure. Consider:
218 -- If x gets an InlineIt, we must remember
219 -- the correct binding for y.
221 | ItsAnAtom OutArg -- Used either (a) to record the cloned Id
222 -- or (b) if the orig defn is a let-binding, and
223 -- the RHS of the let simplifies to an atom,
224 -- we just bind the variable to that atom, and
228 %************************************************************************
230 \subsubsection{The @UnfoldEnv@ type}
232 %************************************************************************
234 The @UnfoldEnv@ contains information about the value of some of the
235 in-scope identifiers. It obeys the following invariant:
237 If the @UnfoldEnv@ contains information, it is safe to use it!
239 In particular, if the @UnfoldEnv@ contains details of an unfolding of
240 an Id, then it's safe to use the unfolding. If, for example, the Id
241 is used many times, then its unfolding won't be put in the UnfoldEnv
244 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
245 because (a)~it's small, and (b)~we need to search its {\em range} as
249 data UnfoldItem -- a glorified triple...
250 = UnfoldItem OutId -- key: used in lookForConstructor
251 UnfoldingDetails -- for that Id
252 EnclosingCcDetails -- so that if we do an unfolding,
253 -- we can "wrap" it in the CC
254 -- that was in force.
256 data UnfoldConApp -- yet another glorified triple
257 = UCA OutId -- same fields as ConForm
260 data UnfoldEnv -- yup, a glorified triple...
261 = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
262 IdSet -- The Ids in the domain of the env
263 -- which have details (GenForm True ...)
264 -- i.e., they claim they are duplicatable.
265 -- These are the ones we have to worry
266 -- about when adding new items to the
268 (FiniteMap UnfoldConApp OutId)
269 -- Maps applications of constructors (to
270 -- types & atoms) back to OutIds that are
271 -- bound to them; i.e., this is a reversed
272 -- mapping for (part of) the main IdEnv
275 null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
278 The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
279 be small, because it contains bindings only for those things whose
280 form or unfolding is known. Basically it maps @Id@ to their
281 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
282 need to search it associatively, to look for @Id@s which have a given
285 We implement it with @IdEnvs@, possibly overkill, but sometimes these
286 things silently grow quite big.... Here are some local functions used
287 elsewhere in the module:
290 grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
291 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
292 lookup_unfold_env_encl_cc
293 :: UnfoldEnv -> OutId -> EnclosingCcDetails
295 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
297 grow_unfold_env (UFE u_env interesting_ids con_apps) id
298 uf_details@(GenForm True _ _ _) encl_cc
299 -- Only interested in Ids which have a "dangerous" unfolding; that is
300 -- one that claims to have a single occurrence.
301 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
302 (addOneToUniqSet interesting_ids id)
305 grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
306 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
313 -> case (lookupFM con_apps entry) of
314 Just _ -> con_apps -- unchanged; we hang onto what we have
315 Nothing -> addToFM con_apps entry id
317 entry = UCA con vargs
319 not_a_constructor -> con_apps -- unchanged
321 addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
322 = ASSERT(not (any constructor_form_in_those extra_items))
323 -- otherwise, we'd need to change con_apps
324 UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
326 constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
327 constructor_form_in_those _ = False
329 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
331 get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
333 foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
334 = UFE (foldr fun u_env stuff) interesting_ids con_apps
336 lookup_unfold_env (UFE u_env _ _) id
337 = case (lookupIdEnv u_env id) of
338 Nothing -> NoUnfoldingDetails
339 Just (UnfoldItem _ uf _) -> uf
341 lookup_unfold_env_encl_cc (UFE u_env _ _) id
342 = case (lookupIdEnv u_env id) of
343 Nothing -> NoEnclosingCcDetails
344 Just (UnfoldItem _ _ encl_cc) -> encl_cc
346 lookup_conapp (UFE _ _ con_apps) con args
347 = lookupFM con_apps (UCA con args)
349 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
350 = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
352 -- If the current binding claims to be a "unique" one, then
354 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
356 modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
357 = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
360 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
361 it, so we can use it for a @FiniteMap@ key.
363 instance Eq UnfoldConApp where
364 a == b = case cmp_app a b of { EQ_ -> True; _ -> False }
365 a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
367 instance Ord UnfoldConApp where
368 a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
369 a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
370 a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
371 a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
372 _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
374 instance Ord3 UnfoldConApp where
377 cmp_app (UCA c1 as1) (UCA c2 as2)
378 = case (c1 `cmp` c2) of
381 _ -> cmp_lists cmp_atom as1 as2
383 cmp_lists cmp_item [] [] = EQ_
384 cmp_lists cmp_item (x:xs) [] = GT_
385 cmp_lists cmp_item [] (y:ys) = LT_
386 cmp_lists cmp_item (x:xs) (y:ys)
387 = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
389 cmp_atom (VarArg x) (VarArg y) = x `cmp` y
390 cmp_atom (VarArg _) _ = LT_
391 cmp_atom (LitArg x) (LitArg y)
392 = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
393 cmp_atom (LitArg _) _ = GT_
396 %************************************************************************
398 \subsubsection{The @EnclosingCcDetails@ type}
400 %************************************************************************
403 data EnclosingCcDetails
404 = NoEnclosingCcDetails
405 | EnclosingCC CostCentre
408 %************************************************************************
410 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
412 %************************************************************************
415 type InId = Id -- Not yet cloned
416 type InBinder = (InId, BinderInfo)
417 type InType = Type -- Ditto
418 type InBinding = SimplifiableCoreBinding
419 type InExpr = SimplifiableCoreExpr
420 type InAlts = SimplifiableCoreCaseAlts
421 type InDefault = SimplifiableCoreCaseDefault
422 type InArg = SimplifiableCoreArg
424 type OutId = Id -- Cloned
426 type OutType = Type -- Cloned
427 type OutBinding = CoreBinding
428 type OutExpr = CoreExpr
429 type OutAlts = CoreCaseAlts
430 type OutDefault = CoreCaseDefault
431 type OutArg = CoreArg
436 type SwitchChecker = SimplifierSwitch -> SwitchResult
439 %************************************************************************
441 \subsection{@SimplEnv@ handling}
443 %************************************************************************
445 %************************************************************************
447 \subsubsection{Command-line switches}
449 %************************************************************************
452 getSwitchChecker :: SimplEnv -> SwitchChecker
453 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
455 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
456 switchIsSet (SimplEnv chkr _ _ _ _) switch
457 = switchIsOn chkr switch
460 %************************************************************************
462 \subsubsection{The ``enclosing cost-centre''}
464 %************************************************************************
467 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
469 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
470 = SimplEnv chkr encl_cc ty_env id_env unfold_env
473 %************************************************************************
475 \subsubsection{The @TypeEnv@ part}
477 %************************************************************************
480 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
482 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
483 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
484 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
486 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
488 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
489 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
490 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
492 new_ty_env = growTyVarEnvList ty_env pairs
494 simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
495 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
498 @replaceInEnvs@ is used to install saved type and id envs
499 when pulling an un-simplified expression out of the environment, which
500 was saved with its environments.
503 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
505 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
507 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
508 (new_ty_env, new_id_env)
509 = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
512 %************************************************************************
514 \subsubsection{The ``Id env'' part}
516 %************************************************************************
521 -> InBinder -> OutArg
524 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
525 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
527 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
529 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
530 (in_id, occ_info) atom@(VarArg out_id)
531 = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
533 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
535 new_unfold_env = modify_unfold_env
537 (modifyItem ok_to_dup occ_info)
539 -- Modify binding for in_id
540 -- NO! modify out_id, because its the info on the
541 -- atom that interest's us.
543 ok_to_dup = switchIsOn chkr SimplOkToDupCode
545 extendIdEnvWithAtomList
547 -> [(InBinder, OutArg)]
549 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
551 extendIdEnvWithInlining
552 :: SimplEnv -- The Env to modify
553 -> SimplEnv -- The Env to record in the inlining. Usually the
554 -- same as the previous one, except in the recursive case
555 -> InBinder -> InExpr
558 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
559 ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
562 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
564 new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
568 -> InBinder -- Old binder; binderinfo ignored
569 -> OutId -- Its new clone, as an Id
572 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
574 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
576 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
578 extendIdEnvWithClones -- Like extendIdEnvWithClone
584 extendIdEnvWithClones (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 = growIdEnvList id_env (in_ids `zipEqual` out_vals)
589 in_ids = [id | (id,_) <- in_binders]
590 out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
592 lookupId :: SimplEnv -> Id -> Maybe IdVal
594 lookupId (SimplEnv _ _ _ id_env _) id
596 = lookupIdEnv id_env id
598 = case (lookupIdEnv id_env id) of
600 xxx -> --false!: ASSERT(not (isLocallyDefined id))
605 %************************************************************************
607 \subsubsection{The @UnfoldEnv@}
609 %************************************************************************
612 extendUnfoldEnvGivenFormDetails
618 extendUnfoldEnvGivenFormDetails
619 env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
622 NoUnfoldingDetails -> env
623 good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
625 new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
627 extendUnfoldEnvGivenConstructor -- specialised variant
629 -> OutId -- bind this to...
630 -> Id -> [OutId] -- "con <tys-to-be-invented> args"
633 extendUnfoldEnvGivenConstructor env var con args
635 -- conjure up the types to which the con should be applied
636 scrut_ty = idType var
637 (_, ty_args, _) = getAppDataTyCon scrut_ty
639 extendUnfoldEnvGivenFormDetails
640 env var (ConForm con (map VarArg args))
644 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
645 of a new binding. There is a horrid case we have to take care about,
646 due to Andr\'e Santos:
648 type Array_type b = Array Int b;
649 type Descr_type = (Int,Int);
651 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
652 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
656 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
657 f_aareorder a_index a_ar=
659 f_aareorder' a_i= a_ar ! (a_index ! a_i)
660 } in tabulate f_aareorder' (bounds a_ar);
661 r_index=tabulate ((+) 1) (1,1);
662 arr = listArray (1,1) a_xs;
663 arg = f_aareorder r_index arr
666 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
668 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
669 in tabulate f_aareorder' (bounds arr)
671 Note that r_index is not inlined, because it was bound to a_index which
672 occurs inside a lambda.
674 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
675 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
676 analyse it, we won't spot the inside-lambda property of r_index, so r_index
677 will get inlined inside the lambda. AARGH.
679 Solution: when we occurrence-analyse the new RHS we have to go back
680 and modify the info recorded in the UnfoldEnv for the free vars
681 of the RHS. In the example we'd go back and record that r_index is now used
685 extendUnfoldEnvGivenRhs
688 -> OutId -- Note: *must* be an "out" Id (post-cloning)
689 -> OutExpr -- Its rhs (*simplified*)
692 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
693 binder@(_,occ_info) out_id rhs
694 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
696 -- Occurrence-analyse the RHS
697 (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
699 interesting_fvs = get_interesting_ids unfold_env
701 -- Compute unfolding details
702 details = case rhs of
703 Var v -> panic "Vars already dealt with"
704 Lit lit | isNoRepLit lit -> LitForm lit
705 | otherwise -> panic "non-noRep Lits already dealt with"
707 Con con args -> ConForm con args
709 other -> mkGenForm ok_to_dup occ_info
710 (mkFormSummary (getIdStrictness out_id) rhs)
713 -- Compute resulting unfold env
714 new_unfold_env = case details of
715 NoUnfoldingDetails -> unfold_env
716 GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
719 -- Add unfolding to unfold env
720 unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
722 -- Modify unfoldings of free vars of rhs, based on their
723 -- occurrence info in the rhs [see notes above]
724 unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
726 modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
727 modify (u, occ_info) env
728 = case (lookupUFM_Directly env u) of
729 Nothing -> env -- ToDo: can this happen?
730 Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
732 -- Compute unfolding guidance
733 guidance = if simplIdWantsToBeINLINEd out_id env
735 else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
737 bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
738 Nothing -> uNFOLDING_CREATION_THRESHOLD
741 ok_to_dup = switchIsOn chkr SimplOkToDupCode
742 || exprSmallEnoughToDup rhs
743 -- [Andy] added, Jun 95
745 {- Reinstated AJG Jun 95; This is needed
746 --example that does not (currently) work
747 --without this extention
760 Omitted SLPJ Feb 95; should, I claim, be unnecessary
761 -- is_really_small looks for things like f a b c
762 -- but making sure there are not *too* many arguments.
763 -- (This is brought to you by *ANDY* Magic Constants, Inc.)
765 = case collectArgs new_rhs of
766 (Var _, _, _, xs) -> length xs < 10
772 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
774 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
775 | not (isLocallyDefined var) -- Imported, so look inside the id
778 | otherwise -- Locally defined, so look in the envt.
779 -- There'll be nothing inside the Id.
780 = lookup_unfold_env unfold_env var
783 We need to remove any @GenForm@ bindings from the UnfoldEnv for
784 the RHS of an Id which has an INLINE pragma.
787 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
789 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
790 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
792 new_unfold_env = null_unfold_env
793 -- This version is really simple. INLINEd things are going to
794 -- be inlined wherever they are used, and then all the
795 -- UnfoldEnv stuff will take effect. Meanwhile, there isn't
796 -- much point in doing anything to the as-yet-un-INLINEd rhs.
798 -- Andy disagrees! Example:
799 -- all xs = foldr (&&) True xs
800 -- any p = all . map p {-# INLINE any #-}
802 -- Problem: any won't get deforested, and so if it's exported and
803 -- the importer doesn't use the inlining, (eg passes it as an arg)
804 -- then we won't get deforestation at all.
806 -- So he'd like not to filter the unfold env at all. But that's a disaster:
809 -- let f = \pq -> BIG
811 -- let g = \y -> f y y
813 -- in ...g...g...g...g...g...
815 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
816 -- and thence copied multiple times when g is inlined.
819 ======================
821 In @lookForConstructor@ we used (before Apr 94) to have a special case
822 for nullary constructors:
825 = -- Don't re-use nullary constructors; it's a waste. Consider
833 -- Here the False in the second case will get replace by "a", hardly
838 but now we only do constructor re-use in let-bindings the special
839 case isn't necessary any more.
842 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
843 = lookup_conapp unfold_env con args