2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplEnv]{Environment stuff for the simplifier}
7 #include "HsVersions.h"
10 nullSimplEnv, combineSimplEnv,
11 pprSimplEnv, -- debugging only
13 extendTyEnv, extendTyEnvList,
16 extendIdEnvWithAtom, extendIdEnvWithAtoms,
17 extendIdEnvWithClone, extendIdEnvWithClones,
22 lookupRhsInfo, lookupOutIdEnv, isEvaluated,
23 extendEnvGivenBinding, extendEnvGivenNewRhs,
24 extendEnvForRecBinding, extendEnvGivenRhsInfo,
28 getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
30 setEnclosingCC, getEnclosingCC,
33 SYN_IE(SwitchChecker),
35 SYN_IE(InIdEnv), SYN_IE(InTypeEnv),
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, noBinderInfo,
51 BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
53 import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
54 import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) )
56 import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup,
57 Unfolding(..), SimpleUnfolding(..), FormSummary(..),
59 calcUnfoldingGuidance, UnfoldingGuidance(..)
61 import CoreUtils ( coreExprCc, unTagBinders )
62 import CostCentre ( CostCentre, noCostCentre, noCostCentreAttached )
63 import FiniteMap -- lots of things
64 import Id ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
66 nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
67 addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
68 SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
69 import IdInfo ( bottomIsGuaranteed, StrictnessInfo )
70 import Literal ( isNoRepLit, Literal{-instances-} )
71 import Maybes ( maybeToBool, expectJust )
72 import Name ( isLocallyDefined )
73 import OccurAnal ( occurAnalyseExpr )
74 import Outputable ( Outputable(..){-instances-} )
75 import PprCore -- various instances
76 import PprStyle ( PprStyle(..) )
77 import PprType ( GenType, GenTyVar )
79 import Type ( eqTy, getAppDataTyConExpandingDicts, applyTypeEnvToTy )
80 import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
81 SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
83 import Unique ( Unique{-instance Outputable-} )
84 import UniqFM ( addToUFM_C, ufmToList, eltsUFM
86 --import UniqSet -- lots of things
87 import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
88 import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
90 type TypeEnv = TyVarEnv Type
91 cmpType = panic "cmpType (SimplEnv)"
94 %************************************************************************
96 \subsection[Simplify-types]{Type declarations}
98 %************************************************************************
101 type InId = Id -- Not yet cloned
102 type InBinder = (InId, BinderInfo)
103 type InType = Type -- Ditto
104 type InBinding = SimplifiableCoreBinding
105 type InExpr = SimplifiableCoreExpr
106 type InAlts = SimplifiableCoreCaseAlts
107 type InDefault = SimplifiableCoreCaseDefault
108 type InArg = SimplifiableCoreArg
110 type OutId = Id -- Cloned
112 type OutType = Type -- Cloned
113 type OutBinding = CoreBinding
114 type OutExpr = CoreExpr
115 type OutAlts = CoreCaseAlts
116 type OutDefault = CoreCaseDefault
117 type OutArg = CoreArg
119 type SwitchChecker = SimplifierSwitch -> SwitchResult
122 %************************************************************************
124 \subsubsection{The @SimplEnv@ type}
126 %************************************************************************
129 INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT
130 this? WDP 94/06) This allows us to neglect keeping everything paired
131 with its static environment.
133 The environment contains bindings for all
135 {\em locally-defined}
138 For such things, any unfolding is found in the environment, not in the
139 Id. Unfoldings in the Id itself are used only for imported things
140 (otherwise we get trouble because we have to simplify the unfoldings
141 inside the Ids, etc.).
147 CostCentre -- The enclosing cost-centre (when profiling)
148 InTypeEnv -- Maps old type variables to new clones
149 InIdEnv -- Maps locally-bound Ids to new clones
150 OutIdEnv -- Info about the values of OutIds
151 ConAppMap -- Maps constructor applications back to OutIds
154 nullSimplEnv :: SwitchChecker -> SimplEnv
157 = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
159 combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
160 combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps)
161 new_env@(SimplEnv _ encl_cc ty_env in_id_env _ _ )
162 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
164 pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
168 %************************************************************************
170 \subsubsection{Command-line switches}
172 %************************************************************************
175 getSwitchChecker :: SimplEnv -> SwitchChecker
176 getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
178 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
179 switchIsSet (SimplEnv chkr _ _ _ _ _) switch
180 = switchIsOn chkr switch
182 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
183 getSimplIntSwitch chkr switch
184 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
187 switchOffInlining :: SimplEnv -> SimplEnv
188 switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
189 = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
191 chkr' EssentialUnfoldingsOnly = SwBool True
192 chkr' other = chkr other
195 %************************************************************************
197 \subsubsection{The ``enclosing cost-centre''}
199 %************************************************************************
202 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
204 setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
205 = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
207 getEnclosingCC :: SimplEnv -> CostCentre
208 getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
211 %************************************************************************
213 \subsubsection{The @TypeEnv@ part}
215 %************************************************************************
218 type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes
220 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
221 extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
222 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
224 new_ty_env = addOneToTyVarEnv ty_env tyvar ty
226 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
227 extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
228 = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
230 new_ty_env = growTyVarEnvList ty_env pairs
232 simplTy (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty
233 simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id
236 %************************************************************************
238 \subsubsection{The ``Id env'' part}
240 %************************************************************************
243 type InIdEnv = IdEnv OutArg -- Maps InIds to their value
244 -- Usually this is just the cloned Id, but if
245 -- if the orig defn is a let-binding, and
246 -- the RHS of the let simplifies to an atom,
247 -- we just bind the variable to that atom, and
252 lookupId :: SimplEnv -> Id -> OutArg
254 lookupId (SimplEnv _ _ _ in_id_env _ _) id
255 = case (lookupIdEnv in_id_env id) of
264 -> OutArg{-Val args only, please-}
267 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
268 (in_id,occ_info) atom
269 = SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
271 new_in_id_env = addOneToIdEnv in_id_env in_id atom
272 new_out_id_env = case atom of
273 LitArg _ -> out_id_env
274 VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
276 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
277 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
280 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
282 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
284 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
286 new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
288 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
289 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
291 = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
293 new_in_id_env = growIdEnvList in_id_env bindings
294 bindings = zipEqual "extendIdEnvWithClones"
295 [id | (id,_) <- in_binders]
299 %************************************************************************
301 \subsubsection{The @OutIdEnv@}
303 %************************************************************************
306 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
307 both locally-bound ones, and perhaps some imported ones too.
310 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
314 The "Id" part is just so that we can recover the domain of the mapping, which
315 IdEnvs don't allow directly.
317 The @BinderInfo@ tells about the occurrences of the @OutId@.
318 Anything that isn't in here should be assumed to occur many times.
319 We keep this info so we can modify it when something changes.
321 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
324 data RhsInfo = NoRhsInfo
325 | OtherLit [Literal] -- It ain't one of these
326 | OtherCon [Id] -- It ain't one of these
328 | InUnfolding SimplEnv -- Un-simplified unfolding
329 SimpleUnfolding -- (need to snag envts therefore)
331 | OutUnfolding CostCentre
332 SimpleUnfolding -- Already-simplified unfolding
334 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
335 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
337 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
339 = case lookupOutIdEnv env id of
340 Just (_,_,info) -> info
343 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
344 -> (OutId, BinderInfo, RhsInfo)
345 -> (OutId, BinderInfo, RhsInfo)
346 modifyOutEnvItem (id, occ, info1) (_, _, info2)
347 = (id, occ, new_info)
349 new_info = case (info1, info2) of
350 (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
351 (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
352 (_, NoRhsInfo) -> info1
358 isEvaluated :: RhsInfo -> Bool
359 isEvaluated (OtherLit _) = True
360 isEvaluated (OtherCon _) = True
361 isEvaluated (InUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
362 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
363 isEvaluated other = False
366 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
367 of a new binding. There is a horrid case we have to take care about,
368 due to Andr\'e Santos:
370 type Array_type b = Array Int b;
371 type Descr_type = (Int,Int);
373 tabulate :: (Int -> x) -> Descr_type -> Array_type x;
374 tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]];
378 f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
379 f_aareorder a_index a_ar=
381 f_aareorder' a_i= a_ar ! (a_index ! a_i)
382 } in tabulate f_aareorder' (bounds a_ar);
383 r_index=tabulate ((+) 1) (1,1);
384 arr = listArray (1,1) a_xs;
385 arg = f_aareorder r_index arr
388 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
390 arg = let f_aareorder' a_i = arr ! (r_index ! a_i)
391 in tabulate f_aareorder' (bounds arr)
393 Note that r_index is not inlined, because it was bound to a_index which
394 occurs inside a lambda.
396 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
397 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
398 analyse it, we won't spot the inside-lambda property of r_index, so r_index
399 will get inlined inside the lambda. AARGH.
401 Solution: when we occurrence-analyse the new RHS we have to go back
402 and modify the info recorded in the UnfoldEnv for the free vars
403 of the RHS. In the example we'd go back and record that r_index is now used
407 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
408 extendEnvGivenNewRhs env out_id rhs
409 = extendEnvGivenBinding env noBinderInfo out_id rhs
411 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
412 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
414 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
416 new_con_apps = extendConApps con_apps out_id rhs
417 new_out_id_env = case guidance of
418 UnfoldNever -> out_id_env -- No new stuff to put in
419 other -> out_id_env_with_unfolding
421 -- If there is an unfolding, we add rhs-info for out_id,
422 -- *and* modify the occ info for rhs's interesting free variables.
424 -- If the out_id is already in the OutIdEnv, then just replace the
425 -- unfolding, leaving occurrence info alone (this must then
426 -- be a call via extendEnvGivenNewRhs).
427 out_id_env_with_unfolding = foldl modifyOccInfo env1 (ufmToList fv_occ_info)
428 env1 = addToUFM_C modifyOutEnvItem out_id_env out_id
429 (out_id, occ_info, OutUnfolding unf_cc unfolding)
431 -- Occurrence-analyse the RHS
432 -- The "interesting" free variables we want occurrence info for are those
433 -- in the OutIdEnv that have only a single occurrence right now.
434 (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
435 interesting_fvs = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env]
437 -- Compute unfolding details
438 unfolding = SimpleUnfolding form_summary guidance template
439 form_summary = mkFormSummary rhs
441 guidance | not (switchIsSet env IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
445 = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
447 bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
449 -- Compute cost centre for thing
450 unf_cc | noCostCentreAttached expr_cc = encl_cc
451 | otherwise = expr_cc
453 expr_cc = coreExprCc rhs
455 extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
456 (out_id, ((_,occ_info), old_rhs))
457 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
459 new_out_id_env = case guidance of
460 UnfoldNever -> out_id_env -- No new stuff to put in
461 other -> out_id_env_with_unfolding
463 -- If there is an unfolding, we add rhs-info for out_id,
464 -- No need to modify occ info because RHS is pre-simplification
465 out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id
466 (out_id, occ_info, InUnfolding env unfolding)
468 -- Compute unfolding details
469 unfolding = SimpleUnfolding form_summary guidance old_rhs
470 form_summary = mkFormSummary old_rhs
472 guidance | not (switchIsSet env IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
476 = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE (unTagBinders old_rhs)
478 bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
480 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
481 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
482 out_id occ_info rhs_info
483 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
485 new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
486 (out_id, occ_info, rhs_info)
491 modifyOccInfo out_id_env (uniq, new_occ)
492 = modifyIdEnv_Directly modify_fn out_id_env uniq
494 modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
496 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
497 = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
499 new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
500 modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
505 %************************************************************************
507 \subsubsection{The @ConAppMap@ type}
509 %************************************************************************
511 The @ConAppMap@ maps applications of constructors (to value atoms)
512 back to an association list that says "if the constructor was applied
513 to one of these lists-of-Types, then this OutId is your man (in a
514 non-gender-specific sense)". I.e., this is a reversed mapping for
515 (part of) the main OutIdEnv
518 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
521 = UCA OutId -- data constructor
522 [OutArg] -- *value* arguments; see use below
526 nullConApps = emptyFM
528 extendConApps con_apps id (Con con args)
529 = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,con)]
531 val_args = filter isValArg args -- Literals and Ids
532 ty_args = [ty | TyArg ty <- args] -- Just types
534 extendConApps con_apps id other_rhs = con_apps
538 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
539 = case lookupFM con_apps (UCA con val_args) of
542 Just assocs -> case [id | (tys, id) <- assocs,
543 and (zipWith eqTy tys ty_args)]
548 val_args = filter isValArg args -- Literals and Ids
549 ty_args = [ty | TyArg ty <- args] -- Just types
553 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
554 for nullary constructors, but now we only do constructor re-use in
555 let-bindings the special case isn't necessary any more.
558 = -- Don't re-use nullary constructors; it's a waste. Consider
566 -- Here the False in the second case will get replace by "a", hardly
572 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
573 it, so we can use it for a @FiniteMap@ key.
576 instance Eq UnfoldConApp where
577 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
578 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
580 instance Ord UnfoldConApp where
581 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
582 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
583 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
584 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
585 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
587 instance Ord3 UnfoldConApp where
590 cmp_app (UCA c1 as1) (UCA c2 as2)
591 = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
593 -- ToDo: make an "instance Ord3 CoreArg"???
595 cmp_arg (VarArg x) (VarArg y) = x `cmp` y
596 cmp_arg (LitArg x) (LitArg y) = x `cmp` y
597 cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
598 cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
600 | tag x _LT_ tag y = LT_
603 tag (VarArg _) = ILIT(1)
604 tag (LitArg _) = ILIT(2)
605 tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
606 tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"