-The can-see-inside-monad functions are the usual sorts of things.
-
-\begin{code}
-thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b
-thenUf m k in_scopes get_id mentioneds
- = case m in_scopes get_id mentioneds of { (v, mentioneds1) ->
- k v in_scopes get_id mentioneds1 }
-
-thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b
-thenUf_ m k in_scopes get_id mentioneds
- = case m in_scopes get_id mentioneds of { (_, mentioneds1) ->
- k in_scopes get_id mentioneds1 }
-
-mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b]
-mapUf f [] = returnUf []
-mapUf f (x:xs)
- = f x `thenUf` \ r ->
- mapUf f xs `thenUf` \ rs ->
- returnUf (r:rs)
-
-returnUf :: a -> UnfoldM bndr a
-returnUf v in_scopes get_id mentioneds = (v, mentioneds)
-
-addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a
-addInScopesUf more_in_scopes m in_scopes get_id mentioneds
- = m (in_scopes `add_some` more_in_scopes) get_id mentioneds
-
-getInScopesUf :: UnfoldM bndr IdSet
-getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds)
-
-extractIdsUf :: [bndr] -> UnfoldM bndr [Id]
-extractIdsUf binders in_scopes get_id mentioneds
- = (map get_id binders, mentioneds)
-
-consider_Id :: Id -> UnfoldM bndr ()
-consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit)
- = let
- (ids2, tcs2, clss2) = whatsMentionedInId in_scopes var
- in
- ((), (ids `unionBags` ids2,
- tcs `unionBags` tcs2,
- clss `unionBags`clss2,
- has_litlit))
-\end{code}
-
-\begin{code}
-addToMentionedIdsUf :: Id -> UnfoldM bndr ()
-addToMentionedTyConsUf :: Bag TyCon -> UnfoldM bndr ()
-addToMentionedClassesUf :: Bag Class -> UnfoldM bndr ()
-litlit_oops :: UnfoldM bndr ()
-
-addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit)
- = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit))
-
-addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
- = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit))
-
-addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
- = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit))
-
-litlit_oops in_scopes get_id (ids, tcs, clss, _)
- = ((), (ids, tcs, clss, True))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Gathering up info for an interface-unfolding}
-%* *
-%************************************************************************
-
-\begin{code}
-{-
-mentionedInUnfolding
- :: (bndr -> Id) -- so we can get Ids out of binders
- -> GenCoreExpr bndr Id -- input expression
- -> (Bag Id, Bag TyCon, Bag Class,
- -- what we found mentioned in the expr
- Bool -- True <=> mentions a ``litlit''-ish thing
- -- (the guy on the other side of an interface
- -- may not be able to handle it)
- )
--}
-
-mentionedInUnfolding get_id expr
- = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of
- (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) ->
- (ids_bag, tcs_bag, clss_bag, has_litlit)
-\end{code}
-
-\begin{code}
---ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr ()
-
-ment_expr (Var v) = consider_Id v
-ment_expr (Lit l) = consider_lit l
-
-ment_expr expr@(Lam _ _)
- = let
- (uvars, tyvars, args, body) = collectBinders expr
- in
- extractIdsUf args `thenUf` \ bs_ids ->
- addInScopesUf bs_ids (
- -- this considering is just to extract any mentioned types/classes
- mapUf consider_Id bs_ids `thenUf_`
- ment_expr body
- )
-
-ment_expr (App fun arg)
- = ment_expr fun `thenUf_`
- ment_arg arg
-
-ment_expr (Con c as)
- = consider_Id c `thenUf_`
- mapUf ment_arg as `thenUf_`
- returnUf ()
-
-ment_expr (Prim op as)
- = ment_op op `thenUf_`
- mapUf ment_arg as `thenUf_`
- returnUf ()
- where
- ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
- = mapUf ment_ty arg_tys `thenUf_`
- ment_ty res_ty
- ment_op other_op = returnUf ()
-
-ment_expr (Case scrutinee alts)
- = ment_expr scrutinee `thenUf_`
- ment_alts alts
-
-ment_expr (Let (NonRec bind rhs) body)
- = ment_expr rhs `thenUf_`
- extractIdsUf [bind] `thenUf` \ bi@[bind_id] ->
- addInScopesUf bi (
- ment_expr body `thenUf_`
- consider_Id bind_id )
-
-ment_expr (Let (Rec pairs) body)
- = let
- binders = map fst pairs
- rhss = map snd pairs
- in
- extractIdsUf binders `thenUf` \ binder_ids ->
- addInScopesUf binder_ids (
- mapUf ment_expr rhss `thenUf_`
- mapUf consider_Id binder_ids `thenUf_`
- ment_expr body )
-
-ment_expr (SCC cc expr)
- = (case (ccMentionsId cc) of
- Just id -> consider_Id id
- Nothing -> returnUf ()
- )
- `thenUf_` ment_expr expr
-
-ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
-
--------------
-ment_ty ty
- = let
- (tycons, clss) = getMentionedTyConsAndClassesFromType ty
- in
- addToMentionedTyConsUf tycons `thenUf_`
- addToMentionedClassesUf clss
-
--------------
-
-ment_alts alg_alts@(AlgAlts alts deflt)
- = mapUf ment_alt alts `thenUf_`
- ment_deflt deflt
- where
- ment_alt alt@(con, params, rhs)
- = consider_Id con `thenUf_`
- extractIdsUf params `thenUf` \ param_ids ->
- addInScopesUf param_ids (
- -- "consider" them so we can chk out their types...
- mapUf consider_Id param_ids `thenUf_`
- ment_expr rhs )
-
-ment_alts (PrimAlts alts deflt)
- = mapUf ment_alt alts `thenUf_`
- ment_deflt deflt
- where
- ment_alt alt@(lit, rhs) = ment_expr rhs
-
-----------------
-ment_deflt NoDefault
- = returnUf ()
-
-ment_deflt d@(BindDefault b rhs)
- = extractIdsUf [b] `thenUf` \ bi@[b_id] ->
- addInScopesUf bi (
- consider_Id b_id `thenUf_`
- ment_expr rhs )
-
------------
-ment_arg (VarArg v) = consider_Id v
-ment_arg (LitArg l) = consider_lit l
-ment_arg (TyArg ty) = ment_ty ty
-ment_arg (UsageArg _) = returnUf ()
-
------------
-consider_lit lit
- | isLitLitLit lit = litlit_oops `thenUf_` returnUf ()
- | otherwise = returnUf ()
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Printing unfoldings in interfaces}
-%* *
-%************************************************************************
-
-Printing Core-expression unfoldings is sufficiently delicate that we
-give it its own function.
-\begin{code}
-{- OLD:
-pprCoreUnfolding
- :: CoreExpr
- -> Pretty
-
-pprCoreUnfolding expr
- = let
- (_, renamed) = instCoreExpr uniqSupply_u expr
- -- We rename every unfolding with a "steady" unique supply,
- -- so that the names won't constantly change.
- -- One place we *MUST NOT* use a splittable UniqueSupply!
- in
- ppr_uf_Expr emptyUniqSet renamed
-
-ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding")
-\end{code}
-
-\begin{code}
-ppr_uf_Expr in_scopes (Var v) = pprIdInUnfolding in_scopes v
-ppr_uf_Expr in_scopes (Lit l) = ppr ppr_Unfolding l
-
-ppr_uf_Expr in_scopes (Con c as)
- = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP,
- ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
- ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-ppr_uf_Expr in_scopes (Prim op as)
- = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP,
- ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
- ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-
-ppr_uf_Expr in_scopes (Lam binder body)
- = ppCat [ppChar '\\', ppr_uf_Binder binder,
- ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add1` binder) body]
-
-ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
- = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->",
- ppr_uf_Expr in_scopes body]
- where
- (tyvars, body) = collect_tyvars expr
-
- collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after )
- where (tyvs, e_after) = collect_tyvars e
- collect_tyvars other_e = ( [], other_e )
-
-ppr_uf_Expr in_scopes expr@(App fun_expr atom)
- = let
- (fun, args) = collect_args expr []
- in
- ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack,
- ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack]
- where
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args fun args = (fun, args)
-
-ppr_uf_Expr in_scopes (CoTyApp expr ty)
- = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr,
- ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}']
-
-ppr_uf_Expr in_scopes (Case scrutinee alts)
- = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
- pp_alts alts, ppChar '}']
- where
- pp_alts (AlgAlts alts deflt)
- = ppCat [ppPStr SLIT("_ALG_"), ppCat (map pp_alg alts), pp_deflt deflt]
- pp_alts (PrimAlts alts deflt)
- = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
-
- pp_alg (con, params, rhs)
- = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP,
- ppIntersperse ppSP (map ppr_uf_Binder params),
- ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi]
-
- pp_prim (lit, rhs)
- = ppBesides [ppr ppr_Unfolding lit,
- ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
-
- pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_")
- pp_deflt (BindDefault binder rhs)
- = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
- ppr_uf_Expr (in_scopes `add1` binder) rhs]
-
-ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body)
- = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
- ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
-
-ppr_uf_Expr in_scopes (Let (Rec pairs) body)
- = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
- ppStr "} in ", ppr_uf_Expr new_in_scopes body]
- where
- sep = ppBeside ppSemi ppSP
- new_in_scopes = in_scopes `add_some` map fst pairs
-
- pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
-
-ppr_uf_Expr in_scopes (SCC cc body)
- = ASSERT(not (noCostCentreAttached cc))
- ASSERT(not (currentOrSubsumedCosts cc))
- ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ", ppr_uf_Expr in_scopes body]
-
-ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce"
-\end{code}
-
-\begin{code}
-ppr_uf_Binder :: Id -> Pretty
-ppr_uf_Binder v
- = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "),
- ppr ppr_Unfolding (idType v), ppRparen]
-
-ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l
-ppr_uf_Atom in_scopes (VarArg v) = pprIdInUnfolding in_scopes v
-END OLD -}
-\end{code}