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,
34 SYN_IE(SwitchChecker),
35 SimplEnv, EnclosingCcDetails(..),
36 SYN_IE(InIdEnv), IdVal(..), SYN_IE(InTypeEnv),
37 UnfoldEnv, UnfoldItem, UnfoldConApp,
39 SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType),
40 SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
42 SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg),
43 SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg)
48 IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop
50 import BinderInfo ( orBinderInfo, oneSafeOcc,
51 BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
53 import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
54 import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult )
56 import CoreUnfold ( UnfoldingDetails(..), mkGenForm, mkConForm,
57 calcUnfoldingGuidance, UnfoldingGuidance(..),
58 mkFormSummary, FormSummary(..)
60 import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup )
61 import FiniteMap -- lots of things
62 import Id ( idType, getIdUnfolding, getIdStrictness,
64 nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
65 addOneToIdEnv, modifyIdEnv, mkIdSet,
66 SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
67 import IdInfo ( bottomIsGuaranteed, StrictnessInfo )
68 import Literal ( isNoRepLit, Literal{-instances-} )
69 import Maybes ( maybeToBool )
70 import Name ( isLocallyDefined )
71 import OccurAnal ( occurAnalyseExpr )
72 import Outputable ( Outputable(..){-instances-} )
73 import PprCore -- various instances
74 import PprStyle ( PprStyle(..) )
75 import PprType ( GenType, GenTyVar )
77 import Type ( eqTy, getAppDataTyConExpandingDicts, applyTypeEnvToTy )
78 import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
79 SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
81 import Unique ( Unique{-instance Outputable-} )
82 import UniqFM ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly,
85 --import UniqSet -- lots of things
86 import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
87 import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
89 type TypeEnv = TyVarEnv Type
90 cmpType = panic "cmpType (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 OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ")
176 [ppr PprDebug l | l <- ls]]
177 OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ")
178 [ppr PprDebug c | c <- cs]]
179 GenForm w e g -> ppCat [ppStr "UF:", ppr PprDebug w,
180 ppr PprDebug g, ppr PprDebug e]
181 MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s]
185 %************************************************************************
187 \subsubsection{The @IdVal@ type (for the ``IdEnv'')}
189 %************************************************************************
191 The unfoldings for imported things are mostly kept within the Id
192 itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For
193 example, suppose \tr{x} is imported, and we have
198 Then within \tr{<body>}, we know that \tr{x} is a pair with components
202 type InIdEnv = IdEnv IdVal -- Maps InIds to their value
205 = InlineIt InIdEnv InTypeEnv InExpr
206 -- No binding of the Id is left;
207 -- You *have* to replace any occurences
208 -- of the id with this expression.
209 -- Rather like a macro, really
210 -- NB: the InIdEnv/InTypeEnv is necessary to prevent
211 -- name caputure. Consider:
216 -- If x gets an InlineIt, we must remember
217 -- the correct binding for y.
219 | ItsAnAtom OutArg -- Used either (a) to record the cloned Id
220 -- or (b) if the orig defn is a let-binding, and
221 -- the RHS of the let simplifies to an atom,
222 -- we just bind the variable to that atom, and
226 %************************************************************************
228 \subsubsection{The @UnfoldEnv@ type}
230 %************************************************************************
232 The @UnfoldEnv@ contains information about the value of some of the
233 in-scope identifiers. It obeys the following invariant:
235 If the @UnfoldEnv@ contains information, it is safe to use it!
237 In particular, if the @UnfoldEnv@ contains details of an unfolding of
238 an Id, then it's safe to use the unfolding. If, for example, the Id
239 is used many times, then its unfolding won't be put in the UnfoldEnv
242 The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
243 because (a)~it's small, and (b)~we need to search its {\em range} as
247 data UnfoldItem -- a glorified triple...
248 = UnfoldItem OutId -- key: used in lookForConstructor
249 UnfoldingDetails -- for that Id
250 EnclosingCcDetails -- so that if we do an unfolding,
251 -- we can "wrap" it in the CC
252 -- that was in force.
254 data UnfoldConApp -- yet another glorified pair
255 = UCA OutId -- data constructor
256 [OutArg] -- *value* arguments; see use below
258 data UnfoldEnv -- yup, a glorified triple...
259 = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
261 (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all)
262 -- in-scope ids. The "Id" part is just so that
263 -- we can recover the domain of the mapping, which
264 -- IdEnvs don't allow directly.
266 -- Anything that isn't in here
267 -- should be assumed to occur many times.
268 -- The things in here all occur once, and the
269 -- binder-info tells about whether that "once"
270 -- is inside a lambda, or perhaps once in each branch
272 -- We keep this info so we can modify it when
273 -- something changes.
275 (FiniteMap UnfoldConApp [([Type], OutId)])
276 -- Maps applications of constructors (to
277 -- value atoms) back to an association list
278 -- that says "if the constructor was applied
279 -- to one of these lists-of-Types, then
280 -- this OutId is your man (in a non-gender-specific
281 -- sense)". I.e., this is a reversed
282 -- mapping for (part of) the main IdEnv
285 null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM
288 The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
289 be small, because it contains bindings only for those things whose
290 form or unfolding is known. Basically it maps @Id@ to their
291 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
292 need to search it associatively, to look for @Id@s which have a given
295 We implement it with @IdEnvs@, possibly overkill, but sometimes these
296 things silently grow quite big.... Here are some local functions used
297 elsewhere in the module:
300 grow_unfold_env :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
301 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
302 lookup_unfold_env_encl_cc
303 :: UnfoldEnv -> OutId -> EnclosingCcDetails
305 grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env
307 grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc
308 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
312 new_occ_env = modify_occ_info occ_env id occ_info
316 GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id)
317 not_a_constructor -> con_apps -- unchanged
319 addto_unfold_env (UFE u_env occ_env con_apps) extra_items
320 = ASSERT(not (any constructor_form_in_those extra_items))
321 -- otherwise, we'd need to change con_apps
322 UFE (growIdEnvList u_env extra_items) occ_env con_apps
324 constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True
325 constructor_form_in_those _ = False
327 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
329 get_interesting_ids (UFE _ occ_env _)
330 = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ]
332 foldr_occ_env fun (UFE u_env occ_env con_apps) stuff
333 = UFE u_env (foldr fun occ_env stuff) 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 = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp"))
348 -- Returns two things; we just fst or snd the one we want:
349 lookup_conapp_help con_apps con args outid
350 = case (span notValArg args) of { (ty_args, val_args) ->
352 entry = UCA con val_args
353 arg_tys = [ t | TyArg t <- ty_args ]
355 case (lookupFM con_apps entry) of
357 addToFM con_apps entry [(arg_tys, outid)])
359 -> ASSERT(not (null assocs))
360 case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of
362 con_apps) -- unchanged; we hang onto what we have
364 addToFM con_apps entry ((arg_tys, outid) : assocs))
365 _ -> panic "grow_unfold_env:dup in assoc list"
369 = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False }
371 cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
372 = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
374 modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _)
375 = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id
377 modify_occ_info occ_env id other_new_occ
378 = -- Many or Dead occurrence, just delete from occ_env
379 delFromUFM occ_env id
382 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
383 it, so we can use it for a @FiniteMap@ key.
385 instance Eq UnfoldConApp where
386 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
387 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
389 instance Ord UnfoldConApp where
390 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
391 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
392 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
393 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
394 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
396 instance Ord3 UnfoldConApp where
399 cmp_app (UCA c1 as1) (UCA c2 as2)
400 = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
402 -- ToDo: make an "instance Ord3 CoreArg"???
404 cmp_arg (VarArg x) (VarArg y) = x `cmp` y
405 cmp_arg (LitArg x) (LitArg y) = x `cmp` y
406 cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
407 cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
409 | tag x _LT_ tag y = LT_
412 tag (VarArg _) = ILIT(1)
413 tag (LitArg _) = ILIT(2)
414 tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
415 tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
418 %************************************************************************
420 \subsubsection{The @EnclosingCcDetails@ type}
422 %************************************************************************
425 data EnclosingCcDetails
426 = NoEnclosingCcDetails
427 | EnclosingCC CostCentre
430 %************************************************************************
432 \subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
434 %************************************************************************
437 type InId = Id -- Not yet cloned
438 type InBinder = (InId, BinderInfo)
439 type InType = Type -- Ditto
440 type InBinding = SimplifiableCoreBinding
441 type InExpr = SimplifiableCoreExpr
442 type InAlts = SimplifiableCoreCaseAlts
443 type InDefault = SimplifiableCoreCaseDefault
444 type InArg = SimplifiableCoreArg
446 type OutId = Id -- Cloned
448 type OutType = Type -- Cloned
449 type OutBinding = CoreBinding
450 type OutExpr = CoreExpr
451 type OutAlts = CoreCaseAlts
452 type OutDefault = CoreCaseDefault
453 type OutArg = CoreArg
455 type SwitchChecker = SimplifierSwitch -> SwitchResult
458 %************************************************************************
460 \subsection{@SimplEnv@ handling}
462 %************************************************************************
464 %************************************************************************
466 \subsubsection{Command-line switches}
468 %************************************************************************
471 getSwitchChecker :: SimplEnv -> SwitchChecker
472 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
474 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
475 switchIsSet (SimplEnv chkr _ _ _ _) switch
476 = switchIsOn chkr switch
479 %************************************************************************
481 \subsubsection{The ``enclosing cost-centre''}
483 %************************************************************************
486 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
488 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
489 = SimplEnv chkr encl_cc ty_env id_env unfold_env
492 %************************************************************************
494 \subsubsection{The @TypeEnv@ part}
496 %************************************************************************
499 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
501 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
502 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
503 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
505 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
507 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
508 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
509 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
511 new_ty_env = growTyVarEnvList ty_env pairs
513 simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
514 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
517 @replaceInEnvs@ is used to install saved type and id envs
518 when pulling an un-simplified expression out of the environment, which
519 was saved with its environments.
522 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
524 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
526 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
527 (new_ty_env, new_id_env)
528 = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
531 %************************************************************************
533 \subsubsection{The ``Id env'' part}
535 %************************************************************************
540 -> InBinder -> OutArg{-Val args only, please-}
543 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
544 (in_id,occ_info) atom@(LitArg lit)
545 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
547 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
549 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps))
550 (in_id, occ_info) atom@(VarArg out_id)
551 = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
553 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
554 new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps
555 -- Modify occ info for out_id
558 extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
561 extendIdEnvWithAtomList
563 -> [(InBinder, OutArg)]
565 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
567 extendIdEnvWithInlining
568 :: SimplEnv -- The Env to modify
569 -> SimplEnv -- The Env to record in the inlining. Usually the
570 -- same as the previous one, except in the recursive case
571 -> InBinder -> InExpr
574 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
575 ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
578 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
580 new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
584 -> InBinder -- Old binder; binderinfo ignored
585 -> OutId -- Its new clone, as an Id
588 extendIdEnvWithClone (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 = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
594 extendIdEnvWithClones -- Like extendIdEnvWithClone
600 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
602 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
604 new_id_env = growIdEnvList id_env (zipEqual "extendIdEnvWithClones" in_ids out_vals)
605 in_ids = [id | (id,_) <- in_binders]
606 out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
608 lookupId :: SimplEnv -> Id -> Maybe IdVal
610 lookupId (SimplEnv _ _ _ id_env _) id
612 = lookupIdEnv id_env id
614 = case (lookupIdEnv id_env id) of
616 xxx -> --false!: ASSERT(not (isLocallyDefined id))
621 %************************************************************************
623 \subsubsection{The @UnfoldEnv@}
625 %************************************************************************
628 extendUnfoldEnvGivenFormDetails
634 extendUnfoldEnvGivenFormDetails
635 env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
638 NoUnfoldingDetails -> env
639 good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
641 new_unfold_env = grow_unfold_env unfold_env id fake_occ_info good_details encl_cc
642 fake_occ_info = {-ToDo!-} ManyOcc 0 -- generally paranoid
644 extendUnfoldEnvGivenConstructor -- specialised variant
646 -> OutId -- bind this to...
647 -> Id -> [OutId] -- "con <tys-to-be-invented> args"
650 extendUnfoldEnvGivenConstructor env var con args
652 -- conjure up the types to which the con should be applied
653 scrut_ty = idType var
654 (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
656 extendUnfoldEnvGivenFormDetails
657 env var (mkConForm con (map TyArg ty_args ++ map VarArg args))
661 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
662 of a new binding. There is a horrid case we have to take care about,
663 due to Andr\'e Santos:
665 type Array_type b = Array Int b;
666 type Descr_type = (Int,Int);
668 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
669 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
673 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
674 f_aareorder a_index a_ar=
676 f_aareorder' a_i= a_ar ! (a_index ! a_i)
677 } in tabulate f_aareorder' (bounds a_ar);
678 r_index=tabulate ((+) 1) (1,1);
679 arr = listArray (1,1) a_xs;
680 arg = f_aareorder r_index arr
683 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
685 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
686 in tabulate f_aareorder' (bounds arr)
688 Note that r_index is not inlined, because it was bound to a_index which
689 occurs inside a lambda.
691 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
692 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
693 analyse it, we won't spot the inside-lambda property of r_index, so r_index
694 will get inlined inside the lambda. AARGH.
696 Solution: when we occurrence-analyse the new RHS we have to go back
697 and modify the info recorded in the UnfoldEnv for the free vars
698 of the RHS. In the example we'd go back and record that r_index is now used
702 extendUnfoldEnvGivenRhs
705 -> OutId -- Note: *must* be an "out" Id (post-cloning)
706 -> OutExpr -- Its rhs (*simplified*)
709 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
710 binder@(_,occ_info) out_id rhs
711 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
713 -- Occurrence-analyse the RHS
714 (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
716 interesting_fvs = get_interesting_ids unfold_env -- Ids in dom of OccEnv
718 -- Compute unfolding details
719 details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs)
722 -- Compute resulting unfold env
723 new_unfold_env = case details of
724 NoUnfoldingDetails -> unfold_env
727 -- Add unfolding to unfold env
728 unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc
730 {- OLD: done in grow_unfold_env
731 -- Modify unfoldings of free vars of rhs, based on their
732 -- occurrence info in the rhs [see notes above]
734 = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info)
736 modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo)
737 modify (u, item@(i,occ_info)) env
738 = if maybeToBool (lookupUFM_Directly env u) then
739 -- it occurred before, so now it occurs multiple times;
740 -- therefore, *delete* it from the occ(urs once) env.
741 delFromUFM_Directly env u
743 else if not (oneSafeOcc ok_to_dup occ_info) then
744 env -- leave it alone
746 addToUFM_Directly env u item
749 -- Compute unfolding guidance
750 guidance = if simplIdWantsToBeINLINEd out_id env
752 else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
754 bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
755 Nothing -> uNFOLDING_CREATION_THRESHOLD
758 ok_to_dup = switchIsOn chkr SimplOkToDupCode
759 --NO: || exprSmallEnoughToDup rhs
760 -- -- [Andy] added, Jun 95
762 {- Reinstated AJG Jun 95; This is needed
763 --example that does not (currently) work
764 --without this extention
777 Omitted SLPJ Feb 95; should, I claim, be unnecessary
778 -- is_really_small looks for things like f a b c
779 -- but making sure there are not *too* many arguments.
780 -- (This is brought to you by *ANDY* Magic Constants, Inc.)
782 = case collectArgs new_rhs of
783 (Var _, _, _, xs) -> length xs < 10
789 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
791 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
792 | not (isLocallyDefined var) -- Imported, so look inside the id
795 | otherwise -- Locally defined, so look in the envt.
796 -- There'll be nothing inside the Id.
797 = lookup_unfold_env unfold_env var
800 We need to remove any @GenForm@ bindings from the UnfoldEnv for
801 the RHS of an Id which has an INLINE pragma.
804 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
806 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
807 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
809 new_unfold_env = null_unfold_env
810 -- This version is really simple. INLINEd things are going to
811 -- be inlined wherever they are used, and then all the
812 -- UnfoldEnv stuff will take effect. Meanwhile, there isn't
813 -- much point in doing anything to the as-yet-un-INLINEd rhs.
815 -- Andy disagrees! Example:
816 -- all xs = foldr (&&) True xs
817 -- any p = all . map p {-# INLINE any #-}
819 -- Problem: any won't get deforested, and so if it's exported and
820 -- the importer doesn't use the inlining, (eg passes it as an arg)
821 -- then we won't get deforestation at all.
823 -- So he'd like not to filter the unfold env at all. But that's a disaster:
826 -- let f = \pq -> BIG
828 -- let g = \y -> f y y
830 -- in ...g...g...g...g...g...
832 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
833 -- and thence copied multiple times when g is inlined.
836 ======================
838 In @lookForConstructor@ we used (before Apr 94) to have a special case
839 for nullary constructors:
842 = -- Don't re-use nullary constructors; it's a waste. Consider
850 -- Here the False in the second case will get replace by "a", hardly
855 but now we only do constructor re-use in let-bindings the special
856 case isn't necessary any more.
859 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
860 = lookup_conapp unfold_env con args