-%************************************************************************
-%* *
-\subsubsection{The @UnfoldEnv@ type}
-%* *
-%************************************************************************
-
-The @UnfoldEnv@ contains information about the value of some of the
-in-scope identifiers. It obeys the following invariant:
-
- If the @UnfoldEnv@ contains information, it is safe to use it!
-
-In particular, if the @UnfoldEnv@ contains details of an unfolding of
-an Id, then it's safe to use the unfolding. If, for example, the Id
-is used many times, then its unfolding won't be put in the UnfoldEnv
-at all.
-
-The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list
-because (a)~it's small, and (b)~we need to search its {\em range} as
-well as its domain.
-
-\begin{code}
-data UnfoldItem -- a glorified triple...
- = UnfoldItem OutId -- key: used in lookForConstructor
- UnfoldingDetails -- for that Id
- EnclosingCcDetails -- so that if we do an unfolding,
- -- we can "wrap" it in the CC
- -- that was in force.
-
-data UnfoldConApp -- yet another glorified pair
- = UCA OutId -- data constructor
- [OutArg] -- *value* arguments; see use below
-
-data UnfoldEnv -- yup, a glorified triple...
- = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem
-
- (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all)
- -- in-scope ids. The "Id" part is just so that
- -- we can recover the domain of the mapping, which
- -- IdEnvs don't allow directly.
- --
- -- Anything that isn't in here
- -- should be assumed to occur many times.
- -- The things in here all occur once, and the
- -- binder-info tells about whether that "once"
- -- is inside a lambda, or perhaps once in each branch
- -- of a case etc.
- -- We keep this info so we can modify it when
- -- something changes.
-
- (FiniteMap UnfoldConApp [([Type], OutId)])
- -- Maps applications of constructors (to
- -- value atoms) back to an association list
- -- that says "if the constructor was applied
- -- to one of these lists-of-Types, then
- -- this OutId is your man (in a non-gender-specific
- -- sense)". I.e., this is a reversed
- -- mapping for (part of) the main IdEnv
- -- (1st part of UFE)
-
-null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM
-\end{code}
-
-The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will
-be small, because it contains bindings only for those things whose
-form or unfolding is known. Basically it maps @Id@ to their
-@UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also
-need to search it associatively, to look for @Id@s which have a given
-constructor form.
-
-We implement it with @IdEnvs@, possibly overkill, but sometimes these
-things silently grow quite big.... Here are some local functions used
-elsewhere in the module:
-
-\begin{code}
-grow_unfold_env :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv
-lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails
-lookup_unfold_env_encl_cc
- :: UnfoldEnv -> OutId -> EnclosingCcDetails
-
-grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env
-
-grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc
- = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc))
- new_occ_env
- new_con_apps
- where
- new_occ_env = modify_occ_info occ_env id occ_info
-
- new_con_apps
- = case uf_details of
- GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id)
- not_a_constructor -> con_apps -- unchanged
-
-addto_unfold_env (UFE u_env occ_env con_apps) extra_items
- = ASSERT(not (any constructor_form_in_those extra_items))
- -- otherwise, we'd need to change con_apps
- UFE (growIdEnvList u_env extra_items) occ_env con_apps
- where
- constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True
- constructor_form_in_those _ = False
-
-rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env
-
-get_interesting_ids (UFE _ occ_env _)
- = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ]
-
-foldr_occ_env fun (UFE u_env occ_env con_apps) stuff
- = UFE u_env (foldr fun occ_env stuff) con_apps
-
-lookup_unfold_env (UFE u_env _ _) id
- = case (lookupIdEnv u_env id) of
- Nothing -> NoUnfoldingDetails
- Just (UnfoldItem _ uf _) -> uf
-
-lookup_unfold_env_encl_cc (UFE u_env _ _) id
- = case (lookupIdEnv u_env id) of
- Nothing -> NoEnclosingCcDetails
- Just (UnfoldItem _ _ encl_cc) -> encl_cc
-
-lookup_conapp (UFE _ _ con_apps) con args
- = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp"))
-
--- Returns two things; we just fst or snd the one we want:
-lookup_conapp_help con_apps con args outid
- = case (span notValArg args) of { (ty_args, val_args) ->
- let
- entry = UCA con val_args
- arg_tys = [ t | TyArg t <- ty_args ]
- in
- case (lookupFM con_apps entry) of
- Nothing -> (Nothing,
- addToFM con_apps entry [(arg_tys, outid)])
- Just assocs
- -> ASSERT(not (null assocs))
- case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of
- [o] -> (Just o,
- con_apps) -- unchanged; we hang onto what we have
- [] -> (Nothing,
- addToFM con_apps entry ((arg_tys, outid) : assocs))
- _ -> panic "grow_unfold_env:dup in assoc list"
- }
- where
- eq_tys ts1 ts2
- = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False }
-
- cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types
- = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-}
-
-modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _)
- = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id
-
-modify_occ_info occ_env id other_new_occ
- = -- Many or Dead occurrence, just delete from occ_env
- delFromUFM occ_env id
-\end{code}
-
-The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
-it, so we can use it for a @FiniteMap@ key.
-\begin{code}
-instance Eq UnfoldConApp where
- a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
-
-instance Ord UnfoldConApp where
- a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-
-instance Ord3 UnfoldConApp where
- cmp = cmp_app
-
-cmp_app (UCA c1 as1) (UCA c2 as2)
- = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
- where
- -- ToDo: make an "instance Ord3 CoreArg"???
-
- cmp_arg (VarArg x) (VarArg y) = x `cmp` y
- cmp_arg (LitArg x) (LitArg y) = x `cmp` y
- cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs"
- cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
- cmp_arg x y
- | tag x _LT_ tag y = LT_
- | otherwise = GT_
- where
- tag (VarArg _) = ILIT(1)
- tag (LitArg _) = ILIT(2)
- tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg"
- tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The @EnclosingCcDetails@ type}
-%* *
-%************************************************************************
-
-\begin{code}
-data EnclosingCcDetails
- = NoEnclosingCcDetails
- | EnclosingCC CostCentre
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms}
-%* *
-%************************************************************************
-
-\begin{code}
-type InId = Id -- Not yet cloned
-type InBinder = (InId, BinderInfo)
-type InType = Type -- Ditto
-type InBinding = SimplifiableCoreBinding
-type InExpr = SimplifiableCoreExpr
-type InAlts = SimplifiableCoreCaseAlts
-type InDefault = SimplifiableCoreCaseDefault
-type InArg = SimplifiableCoreArg
-
-type OutId = Id -- Cloned
-type OutBinder = Id
-type OutType = Type -- Cloned
-type OutBinding = CoreBinding
-type OutExpr = CoreExpr
-type OutAlts = CoreCaseAlts
-type OutDefault = CoreCaseDefault
-type OutArg = CoreArg
-
-\end{code}
-
-\begin{code}
-type SwitchChecker = SimplifierSwitch -> SwitchResult
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@SimplEnv@ handling}
-%* *
-%************************************************************************