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, getAppDataTyConExpandingDicts, 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, thenCmp, cmpList, 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 -- data constructor
257 [OutArg] -- *value* arguments; see use below
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 [([Type], OutId)])
268 -- Maps applications of constructors (to
269 -- value atoms) back to an association list
270 -- that says "if the constructor was applied
271 -- to one of these lists-of-Types, then
272 -- this OutId is your man (in a non-gender-specific
273 -- sense)". I.e., this is a reversed
274 -- mapping for (part of) the main IdEnv
277 null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM
280 The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
281 be small, because it contains bindings only for those things whose
282 form or unfolding is known. Basically it maps @Id@ to their
283 @UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
284 need to search it associatively, to look for @Id@s which have a given
287 We implement it with @IdEnvs@, possibly overkill, but sometimes these
288 things silently grow quite big.... Here are some local functions used
289 elsewhere in the module:
292 grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
293 lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
294 lookup_unfold_env_encl_cc
295 :: UnfoldEnv -> OutId -> EnclosingCcDetails
297 grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env
299 grow_unfold_env (UFE u_env interesting_ids con_apps) id
300 uf_details@(GenForm True _ _ _) encl_cc
301 -- Only interested in Ids which have a "dangerous" unfolding; that is
302 -- one that claims to have a single occurrence.
303 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
304 (addOneToUniqSet interesting_ids id)
307 grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
308 = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
314 ConForm con args -> snd (lookup_conapp_help con_apps con args id)
315 not_a_constructor -> con_apps -- unchanged
317 addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items
318 = ASSERT(not (any constructor_form_in_those extra_items))
319 -- otherwise, we'd need to change con_apps
320 UFE (growIdEnvList u_env extra_items) interesting_ids con_apps
322 constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True
323 constructor_form_in_those _ = False
325 rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
327 get_interesting_ids (UFE _ interesting_ids _) = interesting_ids
329 foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff
330 = UFE (foldr fun u_env stuff) interesting_ids con_apps
332 lookup_unfold_env (UFE u_env _ _) id
333 = case (lookupIdEnv u_env id) of
334 Nothing -> NoUnfoldingDetails
335 Just (UnfoldItem _ uf _) -> uf
337 lookup_unfold_env_encl_cc (UFE u_env _ _) id
338 = case (lookupIdEnv u_env id) of
339 Nothing -> NoEnclosingCcDetails
340 Just (UnfoldItem _ _ encl_cc) -> encl_cc
342 lookup_conapp (UFE _ _ con_apps) con args
343 = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp"))
345 -- Returns two things; we just fst or snd the one we want:
346 lookup_conapp_help con_apps con args outid
347 = case (span notValArg args) of { (ty_args, val_args) ->
349 entry = UCA con val_args
350 arg_tys = [ t | TyArg t <- ty_args ]
352 case (lookupFM con_apps entry) of
354 addToFM con_apps entry [(arg_tys, outid)])
356 -> ASSERT(not (null assocs))
357 case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of
359 con_apps) -- unchanged; we hang onto what we have
361 addToFM con_apps entry ((arg_tys, outid) : assocs))
362 _ -> panic "grow_unfold_env:dup in assoc list"
366 = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False }
368 cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
369 = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
371 modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id
372 = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps
374 -- If the current binding claims to be a "unique" one, then
376 modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem
378 modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc)
379 = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc
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 cmp_app a b of { EQ_ -> True; _ -> False }
387 a /= b = case cmp_app a b of { EQ_ -> False; _ -> True }
389 instance Ord UnfoldConApp where
390 a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
391 a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
392 a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
393 a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
394 _tagCmp a b = case cmp_app a 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) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
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
458 type SwitchChecker = SimplifierSwitch -> SwitchResult
461 %************************************************************************
463 \subsection{@SimplEnv@ handling}
465 %************************************************************************
467 %************************************************************************
469 \subsubsection{Command-line switches}
471 %************************************************************************
474 getSwitchChecker :: SimplEnv -> SwitchChecker
475 getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr
477 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
478 switchIsSet (SimplEnv chkr _ _ _ _) switch
479 = switchIsOn chkr switch
482 %************************************************************************
484 \subsubsection{The ``enclosing cost-centre''}
486 %************************************************************************
489 setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
491 setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc
492 = SimplEnv chkr encl_cc ty_env id_env unfold_env
495 %************************************************************************
497 \subsubsection{The @TypeEnv@ part}
499 %************************************************************************
502 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
504 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
505 extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty
506 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
508 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
510 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
511 extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs
512 = SimplEnv chkr encl_cc new_ty_env id_env unfold_env
514 new_ty_env = growTyVarEnvList ty_env pairs
516 simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty
517 simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id
520 @replaceInEnvs@ is used to install saved type and id envs
521 when pulling an un-simplified expression out of the environment, which
522 was saved with its environments.
525 nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv)
527 replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv
529 replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
530 (new_ty_env, new_id_env)
531 = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env
534 %************************************************************************
536 \subsubsection{The ``Id env'' part}
538 %************************************************************************
543 -> InBinder -> OutArg{-Val args only, please-}
546 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
547 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
549 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
551 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
552 (in_id, occ_info) atom@(VarArg out_id)
553 = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env
555 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom)
557 new_unfold_env = modify_unfold_env
559 (modifyItem ok_to_dup occ_info)
561 -- Modify binding for in_id
562 -- NO! modify out_id, because its the info on the
563 -- atom that interest's us.
565 ok_to_dup = switchIsOn chkr SimplOkToDupCode
568 extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
571 extendIdEnvWithAtomList
573 -> [(InBinder, OutArg)]
575 extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
577 extendIdEnvWithInlining
578 :: SimplEnv -- The Env to modify
579 -> SimplEnv -- The Env to record in the inlining. Usually the
580 -- same as the previous one, except in the recursive case
581 -> InBinder -> InExpr
584 extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env)
585 ~(SimplEnv _ _ inline_ty_env inline_id_env _ )
588 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
590 new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr)
594 -> InBinder -- Old binder; binderinfo ignored
595 -> OutId -- Its new clone, as an Id
598 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env)
600 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
602 new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id))
604 extendIdEnvWithClones -- Like extendIdEnvWithClone
610 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env)
612 = SimplEnv chkr encl_cc ty_env new_id_env unfold_env
614 new_id_env = growIdEnvList id_env (zipEqual "extendIdEnvWithClones" in_ids out_vals)
615 in_ids = [id | (id,_) <- in_binders]
616 out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids]
618 lookupId :: SimplEnv -> Id -> Maybe IdVal
620 lookupId (SimplEnv _ _ _ id_env _) id
622 = lookupIdEnv id_env id
624 = case (lookupIdEnv id_env id) of
626 xxx -> --false!: ASSERT(not (isLocallyDefined id))
631 %************************************************************************
633 \subsubsection{The @UnfoldEnv@}
635 %************************************************************************
638 extendUnfoldEnvGivenFormDetails
644 extendUnfoldEnvGivenFormDetails
645 env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
648 NoUnfoldingDetails -> env
649 good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env
651 new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc
653 extendUnfoldEnvGivenConstructor -- specialised variant
655 -> OutId -- bind this to...
656 -> Id -> [OutId] -- "con <tys-to-be-invented> args"
659 extendUnfoldEnvGivenConstructor env var con args
661 -- conjure up the types to which the con should be applied
662 scrut_ty = idType var
663 (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
665 extendUnfoldEnvGivenFormDetails
666 env var (ConForm con (map TyArg ty_args ++ map VarArg args))
670 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
671 of a new binding. There is a horrid case we have to take care about,
672 due to Andr\'e Santos:
674 type Array_type b = Array Int b;
675 type Descr_type = (Int,Int);
677 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
678 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
682 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
683 f_aareorder a_index a_ar=
685 f_aareorder' a_i= a_ar ! (a_index ! a_i)
686 } in tabulate f_aareorder' (bounds a_ar);
687 r_index=tabulate ((+) 1) (1,1);
688 arr = listArray (1,1) a_xs;
689 arg = f_aareorder r_index arr
692 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
694 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
695 in tabulate f_aareorder' (bounds arr)
697 Note that r_index is not inlined, because it was bound to a_index which
698 occurs inside a lambda.
700 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
701 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
702 analyse it, we won't spot the inside-lambda property of r_index, so r_index
703 will get inlined inside the lambda. AARGH.
705 Solution: when we occurrence-analyse the new RHS we have to go back
706 and modify the info recorded in the UnfoldEnv for the free vars
707 of the RHS. In the example we'd go back and record that r_index is now used
711 extendUnfoldEnvGivenRhs
714 -> OutId -- Note: *must* be an "out" Id (post-cloning)
715 -> OutExpr -- Its rhs (*simplified*)
718 extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
719 binder@(_,occ_info) out_id rhs
720 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
722 -- Occurrence-analyse the RHS
723 (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs
725 interesting_fvs = get_interesting_ids unfold_env
727 -- Compute unfolding details
728 details = case rhs of
729 Var v -> panic "Vars already dealt with"
730 Lit lit | isNoRepLit lit -> LitForm lit
731 | otherwise -> panic "non-noRep Lits already dealt with"
733 Con con args -> ConForm con args
735 other -> mkGenForm ok_to_dup occ_info
736 (mkFormSummary (getIdStrictness out_id) rhs)
739 -- Compute resulting unfold env
740 new_unfold_env = case details of
741 NoUnfoldingDetails -> unfold_env
742 GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -}
745 -- Add unfolding to unfold env
746 unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc
748 -- Modify unfoldings of free vars of rhs, based on their
749 -- occurrence info in the rhs [see notes above]
750 unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info)
752 modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem
753 modify (u, occ_info) env
754 = case (lookupUFM_Directly env u) of
755 Nothing -> env -- ToDo: can this happen?
756 Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx)
758 -- Compute unfolding guidance
759 guidance = if simplIdWantsToBeINLINEd out_id env
761 else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
763 bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of
764 Nothing -> uNFOLDING_CREATION_THRESHOLD
767 ok_to_dup = switchIsOn chkr SimplOkToDupCode
768 || exprSmallEnoughToDup rhs
769 -- [Andy] added, Jun 95
771 {- Reinstated AJG Jun 95; This is needed
772 --example that does not (currently) work
773 --without this extention
786 Omitted SLPJ Feb 95; should, I claim, be unnecessary
787 -- is_really_small looks for things like f a b c
788 -- but making sure there are not *too* many arguments.
789 -- (This is brought to you by *ANDY* Magic Constants, Inc.)
791 = case collectArgs new_rhs of
792 (Var _, _, _, xs) -> length xs < 10
798 lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
800 lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var
801 | not (isLocallyDefined var) -- Imported, so look inside the id
804 | otherwise -- Locally defined, so look in the envt.
805 -- There'll be nothing inside the Id.
806 = lookup_unfold_env unfold_env var
809 We need to remove any @GenForm@ bindings from the UnfoldEnv for
810 the RHS of an Id which has an INLINE pragma.
813 filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
815 filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env)
816 = SimplEnv chkr encl_cc ty_env id_env new_unfold_env
818 new_unfold_env = null_unfold_env
819 -- This version is really simple. INLINEd things are going to
820 -- be inlined wherever they are used, and then all the
821 -- UnfoldEnv stuff will take effect. Meanwhile, there isn't
822 -- much point in doing anything to the as-yet-un-INLINEd rhs.
824 -- Andy disagrees! Example:
825 -- all xs = foldr (&&) True xs
826 -- any p = all . map p {-# INLINE any #-}
828 -- Problem: any won't get deforested, and so if it's exported and
829 -- the importer doesn't use the inlining, (eg passes it as an arg)
830 -- then we won't get deforestation at all.
832 -- So he'd like not to filter the unfold env at all. But that's a disaster:
835 -- let f = \pq -> BIG
837 -- let g = \y -> f y y
839 -- in ...g...g...g...g...g...
841 -- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
842 -- and thence copied multiple times when g is inlined.
845 ======================
847 In @lookForConstructor@ we used (before Apr 94) to have a special case
848 for nullary constructors:
851 = -- Don't re-use nullary constructors; it's a waste. Consider
859 -- Here the False in the second case will get replace by "a", hardly
864 but now we only do constructor re-use in let-bindings the special
865 case isn't necessary any more.
868 lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args
869 = lookup_conapp unfold_env con args