2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplEnv]{Environment stuff for the simplifier}
8 nullSimplEnv, combineSimplEnv,
9 pprSimplEnv, -- debugging only
11 extendTyEnv, extendTyEnvList, extendTyEnvEnv,
14 extendIdEnvWithAtom, extendIdEnvWithAtoms,
15 extendIdEnvWithClone, extendIdEnvWithClones,
20 lookupRhsInfo, lookupOutIdEnv, isEvaluated,
21 extendEnvGivenBinding, extendEnvGivenNewRhs,
22 extendEnvGivenRhsInfo, extendEnvGivenInlining,
26 getSwitchChecker, switchIsSet, getSimplIntSwitch,
27 switchOffInlining, setCaseScrutinee,
29 setEnclosingCC, getEnclosingCC,
38 InId, InBinder, InBinding, InType,
39 OutId, OutBinder, OutBinding, OutType,
41 InExpr, InAlts, InDefault, InArg,
42 OutExpr, OutAlts, OutDefault, OutArg
45 #include "HsVersions.h"
47 import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
49 BinderInfo {-instances, too-}
51 import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
52 SimplifierSwitch(..), SwitchResult(..)
55 import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
56 Unfolding(..), SimpleUnfolding(..), FormSummary(..),
57 calcUnfoldingGuidance )
58 import CoreUtils ( coreExprCc )
59 import CostCentre ( CostCentre, subsumedCosts, noCostCentreAttached )
60 import FiniteMap -- lots of things
61 import Id ( applyTypeEnvToId, getInlinePragma,
62 nullIdEnv, growIdEnvList, lookupIdEnv,
63 addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly,
64 IdEnv, IdSet, GenId, Id )
65 import Literal ( Literal{-instances-} )
66 import Maybes ( expectJust )
67 import OccurAnal ( occurAnalyseExpr )
68 import PprCore -- various instances
69 import PprType ( GenType, GenTyVar )
70 import Type ( instantiateTy, Type )
71 import TyVar ( emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList,
72 TyVarEnv, GenTyVar{-instance Eq-} ,
75 import Unique ( Unique{-instance Outputable-}, Uniquable(..) )
76 import UniqFM ( addToUFM, addToUFM_C, ufmToList )
77 import Util ( Eager, returnEager, zipEqual, thenCmp, cmpList )
81 %************************************************************************
83 \subsection[Simplify-types]{Type declarations}
85 %************************************************************************
88 type InId = Id -- Not yet cloned
89 type InBinder = (InId, BinderInfo)
90 type InType = Type -- Ditto
91 type InBinding = SimplifiableCoreBinding
92 type InExpr = SimplifiableCoreExpr
93 type InAlts = SimplifiableCoreCaseAlts
94 type InDefault = SimplifiableCoreCaseDefault
95 type InArg = SimplifiableCoreArg
97 type OutId = Id -- Cloned
99 type OutType = Type -- Cloned
100 type OutBinding = CoreBinding
101 type OutExpr = CoreExpr
102 type OutAlts = CoreCaseAlts
103 type OutDefault = CoreCaseDefault
104 type OutArg = CoreArg
106 type SwitchChecker = SimplifierSwitch -> SwitchResult
109 %************************************************************************
111 \subsubsection{The @SimplEnv@ type}
113 %************************************************************************
116 INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
117 this? WDP 94/06) This allows us to neglect keeping everything paired
118 with its static environment.
120 The environment contains bindings for all
122 {\em locally-defined}
125 For such things, any unfolding is found in the environment, not in the
126 Id. Unfoldings in the Id itself are used only for imported things
127 (otherwise we get trouble because we have to simplify the unfoldings
128 inside the Ids, etc.).
134 CostCentre -- The enclosing cost-centre (when profiling)
135 InTypeEnv -- Maps old type variables to new clones
136 InIdEnv -- Maps locally-bound Ids to new clones
137 OutIdEnv -- Info about the values of OutIds
138 ConAppMap -- Maps constructor applications back to OutIds
141 nullSimplEnv :: SwitchChecker -> SimplEnv
144 = SimplEnv sw_chkr subsumedCosts emptyTyVarEnv nullIdEnv nullIdEnv nullConApps
146 combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
147 combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps)
148 new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ )
149 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
151 pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
155 %************************************************************************
157 \subsubsection{Command-line switches}
159 %************************************************************************
162 getSwitchChecker :: SimplEnv -> SwitchChecker
163 getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
165 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
166 switchIsSet (SimplEnv chkr _ _ _ _ _) switch
167 = switchIsOn chkr switch
169 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
170 getSimplIntSwitch chkr switch
171 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
174 setCaseScrutinee :: SimplEnv -> SimplEnv
175 setCaseScrutinee (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
176 = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
178 chkr' SimplCaseScrutinee = SwBool True
179 chkr' other = chkr other
182 @switchOffInlining@ is used to prepare the environment for simplifying
183 the RHS of an Id that's marked with an INLINE pragma. It is going to
184 be inlined wherever they are used, and then all the inlining will take
185 effect. Meanwhile, there isn't much point in doing anything to the
186 as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
188 (a) not doing so will inline a worker straight back into its wrapper!
190 and (b) Consider the following example
195 in ...g...g...g...g...g...
197 Now, if that's the ONLY occurrence of f, it will be inlined inside g,
198 and thence copied multiple times when g is inlined.
200 Andy disagrees! Example:
201 all xs = foldr (&&) True xs
202 any p = all . map p {-# INLINE any #-}
204 Problem: any won't get deforested, and so if it's exported and
205 the importer doesn't use the inlining, (eg passes it as an arg)
206 then we won't get deforestation at all.
207 We havn't solved this problem yet!
209 We prepare the envt by simply discarding the out_id_env, which has
210 all the unfolding info. At one point we did it by modifying the chkr so
211 that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important,
212 simplifications happening in the body of the RHS.
215 switchOffInlining :: SimplEnv -> SimplEnv
216 switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
217 = SimplEnv chkr encl_cc ty_env in_id_env nullIdEnv nullConApps
220 %************************************************************************
222 \subsubsection{The ``enclosing cost-centre''}
224 %************************************************************************
227 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
229 setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
230 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
232 getEnclosingCC :: SimplEnv -> CostCentre
233 getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
236 %************************************************************************
238 \subsubsection{The @TypeEnv@ part}
240 %************************************************************************
243 type TypeEnv = TyVarEnv Type
244 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
246 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
247 extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
248 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
250 new_ty_env = addToTyVarEnv ty_env tyvar ty
252 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
253 extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
254 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
256 new_ty_env = growTyVarEnvList ty_env pairs
258 extendTyEnvEnv :: SimplEnv -> TypeEnv -> SimplEnv
259 extendTyEnvEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) new_ty_env
260 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
262 new_ty_env = ty_env `plusTyVarEnv` new_ty_env
264 simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (instantiateTy ty_env ty)
265 simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id)
268 %************************************************************************
270 \subsubsection{The ``Id env'' part}
272 %************************************************************************
275 type InIdEnv = IdEnv OutArg -- Maps InIds to their value
276 -- Usually this is just the cloned Id, but if
277 -- if the orig defn is a let-binding, and
278 -- the RHS of the let simplifies to an atom,
279 -- we just bind the variable to that atom, and
284 lookupId :: SimplEnv -> Id -> Eager ans OutArg
286 lookupId (SimplEnv _ _ _ in_id_env _ _) id
287 = case (lookupIdEnv in_id_env id) of
288 Just atom -> returnEager atom
289 Nothing -> returnEager (VarArg id)
296 -> OutArg{-Val args only, please-}
299 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
300 (in_id,occ_info) atom
302 LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
303 VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env
304 (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
305 --SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
307 new_in_id_env = addOneToIdEnv in_id_env in_id atom
309 new_out_id_env = case atom of
310 LitArg _ -> out_id_env
311 VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
314 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
315 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
318 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
320 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
322 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
324 new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
326 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
327 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
329 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
331 new_in_id_env = growIdEnvList in_id_env bindings
332 bindings = zipEqual "extendIdEnvWithClones"
333 [id | (id,_) <- in_binders]
337 %************************************************************************
339 \subsubsection{The @OutIdEnv@}
341 %************************************************************************
344 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
345 both locally-bound ones, and perhaps some imported ones too.
348 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
352 The "Id" part is just so that we can recover the domain of the mapping, which
353 IdEnvs don't allow directly.
355 The @BinderInfo@ tells about the occurrences of the @OutId@.
356 Anything that isn't in here should be assumed to occur many times.
357 We keep this info so we can modify it when something changes.
359 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
362 data RhsInfo = NoRhsInfo
363 | OtherLit [Literal] -- It ain't one of these
364 | OtherCon [Id] -- It ain't one of these
366 -- InUnfolding is used for let(rec) bindings that
367 -- are *definitely* going to be inlined.
368 -- We record the un-simplified RHS and drop the binding
369 | InUnfolding SimplEnv -- Un-simplified unfolding
370 SimplifiableCoreExpr -- (need to snag envts therefore)
372 | OutUnfolding CostCentre
373 SimpleUnfolding -- Already-simplified unfolding
375 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
376 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
378 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
380 = case lookupOutIdEnv env id of
381 Just (_,_,info) -> info
384 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
385 -> (OutId, BinderInfo, RhsInfo)
386 -> (OutId, BinderInfo, RhsInfo)
387 modifyOutEnvItem (id, occ, info1) (_, _, info2)
388 = case (info1, info2) of
389 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
390 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
391 (_, NoRhsInfo) -> (id,occ, info1)
392 other -> (id,occ, info2)
397 isEvaluated :: RhsInfo -> Bool
398 isEvaluated (OtherLit _) = True
399 isEvaluated (OtherCon _) = True
400 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
401 isEvaluated other = False
407 mkSimplUnfoldingGuidance chkr out_id rhs
408 = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
410 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
411 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
412 out_id occ_info rhs_info
413 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
415 new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
416 (out_id, occ_info, rhs_info)
421 modifyOccInfo out_id_env (uniq, new_occ)
422 = modifyIdEnv_Directly modify_fn out_id_env uniq
424 modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
426 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
427 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
429 new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
430 modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
435 extendEnvGivenInlining :: SimplEnv -> Id -> BinderInfo -> InExpr -> SimplEnv
436 extendEnvGivenInlining env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
438 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
440 new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs)
443 %************************************************************************
445 \subsubsection{The @ConAppMap@ type}
447 %************************************************************************
449 The @ConAppMap@ maps applications of constructors (to value atoms)
450 back to an association list that says "if the constructor was applied
451 to one of these lists-of-Types, then this OutId is your man (in a
452 non-gender-specific sense)". I.e., this is a reversed mapping for
453 (part of) the main OutIdEnv
456 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
459 = UCA OutId -- data constructor
460 [OutArg] -- *value* arguments; see use below
464 nullConApps = emptyFM
466 extendConApps con_apps id (Con con args)
467 = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
469 val_args = filter isValArg args -- Literals and Ids
470 ty_args = [ty | TyArg ty <- args] -- Just types
472 extendConApps con_apps id other_rhs = con_apps
476 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
477 = case lookupFM con_apps (UCA con val_args) of
480 Just assocs -> case [id | (tys, id) <- assocs,
481 and (zipWith (==) tys ty_args)]
486 val_args = filter isValArg args -- Literals and Ids
487 ty_args = [ty | TyArg ty <- args] -- Just types
491 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
492 for nullary constructors, but now we only do constructor re-use in
493 let-bindings the special case isn't necessary any more.
496 = -- Don't re-use nullary constructors; it's a waste. Consider
504 -- Here the False in the second case will get replace by "a", hardly
510 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
511 it, so we can use it for a @FiniteMap@ key.
514 instance Eq UnfoldConApp where
515 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
516 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
518 instance Ord UnfoldConApp where
519 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
520 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
521 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
522 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
523 compare a b = cmp_app a b
525 cmp_app (UCA c1 as1) (UCA c2 as2)
526 = compare c1 c2 `thenCmp` cmpList cmp_arg as1 as2
528 -- ToDo: make an "instance Ord CoreArg"???
530 cmp_arg (VarArg x) (VarArg y) = x `compare` y
531 cmp_arg (LitArg x) (LitArg y) = x `compare` y
532 cmp_arg (TyArg x) (TyArg y) = panic "SimplEnv.cmp_app:TyArgs"
534 | tag x _LT_ tag y = LT
537 tag (VarArg _) = ILIT(1)
538 tag (LitArg _) = ILIT(2)
539 tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
543 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
544 of a new binding. There is a horrid case we have to take care about,
545 due to Andr\'e Santos:
547 type Array_type b = Array Int b;
548 type Descr_type = (Int,Int);
550 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
551 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
555 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
556 f_aareorder a_index a_ar=
558 f_aareorder' a_i= a_ar ! (a_index ! a_i)
559 } in tabulate f_aareorder' (bounds a_ar);
560 r_index=tabulate ((+) 1) (1,1);
561 arr = listArray (1,1) a_xs;
562 arg = f_aareorder r_index arr
565 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
567 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
568 in tabulate f_aareorder' (bounds arr)
570 Note that r_index is not inlined, because it was bound to a_index which
571 occurs inside a lambda.
573 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
574 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
575 analyse it, we won't spot the inside-lambda property of r_index, so r_index
576 will get inlined inside the lambda. AARGH.
578 Solution: when we occurrence-analyse the new RHS we have to go back
579 and modify the info recorded in the UnfoldEnv for the free vars
580 of the RHS. In the example we'd go back and record that r_index is now used
584 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
585 extendEnvGivenNewRhs env out_id rhs
586 = extendEnvGivenBinding env noBinderInfo out_id rhs
588 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
589 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
591 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
593 new_out_id_env | okToInline (whnfOrBottom form)
594 (couldBeSmallEnoughToInline guidance)
596 = out_id_env_with_unfolding
599 -- Don't bother to extend the OutIdEnv unless there is some possibility
600 -- that the thing might be inlined. We check this by calling okToInline suitably.
602 new_con_apps = _scc_ "eegnr.conapps"
603 extendConApps con_apps out_id rhs
605 -- Modify the occ info for rhs's interesting free variables.
606 out_id_env_with_unfolding = _scc_ "eegnr.modify_occ"
607 foldl modifyOccInfo env1 full_fv_occ_info
608 -- NB: full_fv_occ_info *combines* the occurrence of the current binder
609 -- with the occurrences of its RHS's free variables. That's to take
611 -- let a = \x -> BIG in
613 -- in ...b...b...b...
614 -- Here "a" occurs exactly once. "b" simplifies to a small value.
615 -- So "b" will be inlined at each call site, and there's a good chance
616 -- that "a" will too. So we'd better modify "a"s occurrence info to
617 -- record the fact that it can now occur many times by virtue that "b" can.
619 full_fv_occ_info = _scc_ "eegnr.full_fv"
620 [ (uniq, fv_occ `andBinderInfo` occ_info)
621 | (uniq, fv_occ) <- ufmToList fv_occ_info
624 -- Add an unfolding and rhs_info for the new Id.
625 -- If the out_id is already in the OutIdEnv (which can happen if
626 -- the call to extendEnvGivenBinding is from extendEnvGivenNewRhs)
627 -- then just replace the unfolding, leaving occurrence info alone.
628 env1 = _scc_ "eegnr.modify_out"
629 addToUFM_C modifyOutEnvItem out_id_env out_id
630 (out_id, occ_info, rhs_info)
632 -- Occurrence-analyse the RHS
633 -- The "interesting" free variables we want occurrence info for are those
634 -- in the OutIdEnv that have only a single occurrence right now.
635 (fv_occ_info, template) = _scc_ "eegnr.occ-anal"
636 occurAnalyseExpr is_interesting rhs
638 is_interesting v = _scc_ "eegnr.mkidset"
639 case lookupIdEnv out_id_env v of
640 Just (_, occ, _) -> isOneOcc occ
643 -- Compute unfolding details
644 rhs_info = OutUnfolding unf_cc (SimpleUnfolding form guidance template)
645 form = _scc_ "eegnr.form_sum"
647 guidance = _scc_ "eegnr.guidance"
648 mkSimplUnfoldingGuidance chkr out_id rhs
650 -- Compute cost centre for thing
651 unf_cc | noCostCentreAttached expr_cc = encl_cc
652 | otherwise = expr_cc
654 expr_cc = coreExprCc rhs