+
+
+\begin{code}
+mkSimplUnfoldingGuidance chkr out_id rhs
+ = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
+
+extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
+extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+ out_id occ_info rhs_info
+ = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+ where
+ new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
+ (out_id, occ_info, rhs_info)
+\end{code}
+
+
+\begin{code}
+modifyOccInfo out_id_env (uniq, new_occ)
+ = modifyIdEnv_Directly modify_fn out_id_env uniq
+ where
+ modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
+
+markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
+ = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+ where
+ new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
+ modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsubsection{The @ConAppMap@ type}
+%* *
+%************************************************************************
+
+The @ConAppMap@ 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 OutIdEnv
+
+\begin{code}
+type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
+
+data UnfoldConApp
+ = UCA OutId -- data constructor
+ [OutArg] -- *value* arguments; see use below
+\end{code}
+
+\begin{code}
+nullConApps = emptyFM
+
+extendConApps con_apps id (Con con args)
+ = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
+ where
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
+
+extendConApps con_apps id other_rhs = con_apps
+\end{code}
+
+\begin{code}
+lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
+ = case lookupFM con_apps (UCA con val_args) of
+ Nothing -> Nothing
+
+ Just assocs -> case [id | (tys, id) <- assocs,
+ and (zipWith eqTy tys ty_args)]
+ of
+ [] -> Nothing
+ (id:_) -> Just id
+ where
+ val_args = filter isValArg args -- Literals and Ids
+ ty_args = [ty | TyArg ty <- args] -- Just types
+
+\end{code}
+
+NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
+for nullary constructors, but now we only do constructor re-use in
+let-bindings the special case isn't necessary any more.
+
+\begin{verbatim}
+ = -- Don't re-use nullary constructors; it's a waste. Consider
+ -- let
+ -- a = leInt#! p q
+ -- in
+ -- case a of
+ -- True -> ...
+ -- False -> False
+ --
+ -- Here the False in the second case will get replace by "a", hardly
+ -- a good idea
+ Nothing
+\end{verbatim}
+
+
+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}
+
+
+
+
+
+============================ OLD ================================
+ This version was used when we use the *simplified* RHS of a
+ let as the thing's unfolding. The has the nasty property described
+ in the following comments. Much worse, it can fail to terminate
+ on recursive things. Consider
+
+ letrec f = \x -> let z = f x' in ...
+
+ in
+ let n = f y
+ in
+ case n of { ... }
+
+ If we bind n to its *simplified* RHS, we then *re-simplify* it when
+ we inline n. Then we may well inline f; and then the same thing
+ happens with z!
+
+