2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[CoreUnfold]{Core-syntax unfoldings}
6 Unfoldings (which can travel across module boundaries) are in Core
7 syntax (namely @CoreExpr@s).
9 The type @Unfolding@ sits ``above'' simply-Core-expressions
10 unfoldings, capturing ``higher-level'' things we know about a binding,
11 usually things that the simplifier found out (e.g., ``it's a
12 literal''). In the corner of a @SimpleUnfolding@ unfolding, you will
13 find, unsurprisingly, a Core expression.
16 #include "HsVersions.h"
19 SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
21 FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
23 smallEnoughToInline, couldBeSmallEnoughToInline,
27 calcUnfoldingGuidance,
32 IMPORT_DELOOPER(IdLoop) -- for paranoia checking;
33 -- and also to get mkMagicUnfoldingFun
34 IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
36 import Bag ( emptyBag, unitBag, unionBags, Bag )
37 import CgCompInfo ( uNFOLDING_CHEAP_OP_COST,
38 uNFOLDING_DEAR_OP_COST,
39 uNFOLDING_NOREP_LIT_COST
42 import CoreUtils ( coreExprType )
43 import CostCentre ( ccMentionsId )
44 import Id ( idType, getIdArity, isBottomingId,
45 SYN_IE(IdSet), GenId{-instances-} )
46 import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
47 import IdInfo ( arityMaybe, bottomIsGuaranteed )
48 import Literal ( isNoRepLit, isLitLitLit )
50 import TyCon ( tyConFamilySize )
51 import Type ( maybeAppDataTyConExpandingDicts )
52 import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
53 addOneToUniqSet, unionUniqSets
55 import Usage ( SYN_IE(UVar) )
56 import Util ( isIn, panic, assertPanic )
58 whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
59 getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
62 %************************************************************************
64 \subsection{@Unfolding@ and @UnfoldingGuidance@ types}
66 %************************************************************************
71 | CoreUnfolding SimpleUnfolding
73 Unique -- of the Id whose magic unfolding this is
78 = SimpleUnfolding FormSummary -- Tells whether the template is a WHNF or bottom
79 UnfoldingGuidance -- Tells about the *size* of the template.
80 TemplateOutExpr -- The template
82 type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
83 -- An OutExpr with occurrence info attached. This is used as
84 -- a template in GeneralForms.
87 mkSimpleUnfolding form guidance template
88 = SimpleUnfolding form guidance template
90 mkMagicUnfolding :: Unique -> Unfolding
91 mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
94 data UnfoldingGuidance
96 | UnfoldAlways -- There is no "original" definition,
97 -- so you'd better unfold. Or: something
98 -- so cheap to unfold (e.g., 1#) that
99 -- you should do it absolutely always.
101 | UnfoldIfGoodArgs Int -- if "m" type args
102 Int -- and "n" value args
103 [Int] -- Discount if the argument is evaluated.
104 -- (i.e., a simplification will definitely
105 -- be possible). One elt of the list per *value* arg.
106 Int -- The "size" of the unfolding; to be elaborated
111 instance Outputable UnfoldingGuidance where
112 ppr sty UnfoldAlways = ppStr "_ALWAYS_"
113 -- ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface
114 ppr sty (UnfoldIfGoodArgs t v cs size)
115 = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v,
116 if null cs -- always print *something*
118 else ppBesides (map (ppStr . show) cs),
123 %************************************************************************
125 \subsection{Figuring out things about expressions}
127 %************************************************************************
131 = VarForm -- Expression is a variable (or scc var, etc)
132 | ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
133 | BottomForm -- Expression is guaranteed to be bottom. We're more gung
134 -- ho about inlining such things, because it can't waste work
135 | OtherForm -- Anything else
137 instance Outputable FormSummary where
138 ppr sty VarForm = ppStr "Var"
139 ppr sty ValueForm = ppStr "Value"
140 ppr sty BottomForm = ppStr "Bot"
141 ppr sty OtherForm = ppStr "Other"
143 mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary
146 = go (0::Int) expr -- The "n" is the number of (value) arguments so far
148 go n (Lit _) = ASSERT(n==0) ValueForm
149 go n (Con _ _) = ASSERT(n==0) ValueForm
150 go n (Prim _ _) = OtherForm
151 go n (SCC _ e) = go n e
152 go n (Coerce _ _ e) = go n e
153 go n (Let _ e) = OtherForm
154 go n (Case _ _) = OtherForm
156 go 0 (Lam (ValBinder x) e) = ValueForm -- NB: \x.bottom /= bottom!
157 go n (Lam (ValBinder x) e) = go (n-1) e -- Applied lambda
158 go n (Lam other_binder e) = go n e
160 go n (App fun arg) | isValArg arg = go (n+1) fun
161 go n (App fun other_arg) = go n fun
163 go n (Var f) | isBottomingId f = BottomForm
164 go 0 (Var f) = VarForm
165 go n (Var f) = case (arityMaybe (getIdArity f)) of
166 Just arity | n < arity -> ValueForm
169 whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
170 whnfOrBottom e = case mkFormSummary e of
179 exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
180 exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
181 exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
182 exprSmallEnoughToDup expr
183 = case (collectArgs expr) of { (fun, _, _, vargs) ->
185 Var v | length vargs == 0 -> True
191 exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
192 = case (collectArgs expr) of { (fun, _, _, vargs) ->
194 Var v -> v /= buildId
196 && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
201 Question (ADR): What is the above used for? Is a _ccall_ really small
204 %************************************************************************
206 \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
208 %************************************************************************
211 calcUnfoldingGuidance
212 :: Bool -- True <=> OK if _scc_s appear in expr
213 -> Int -- bomb out if size gets bigger than this
214 -> CoreExpr -- expression to look at
217 calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
219 (use_binders, ty_binders, val_binders, body) = collectBinders expr
221 case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
223 Nothing -> UnfoldNever
225 Just (size, cased_args)
227 uf = UnfoldIfGoodArgs
230 (map discount_for val_binders)
234 | is_data && b `is_elem` cased_args = tyConFamilySize tycon
238 = --trace "CoreUnfold.getAppDataTyConExpandingDicts:1" $
239 case (maybeAppDataTyConExpandingDicts (idType b)) of
240 Nothing -> (False, panic "discount")
241 Just (tc,_,_) -> (True, tc)
243 -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr))
246 is_elem = isIn "calcUnfoldingGuidance"
250 sizeExpr :: Bool -- True <=> _scc_s OK
251 -> Int -- Bomb out if it gets bigger than this
252 -> [Id] -- Arguments; we're interested in which of these
255 -> Maybe (Int, -- Size
256 [Id] -- Subset of args which are cased
259 sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
262 size_up (Var v) = sizeOne
263 size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
264 size_up (Lit lit) = if isNoRepLit lit
265 then sizeN uNFOLDING_NOREP_LIT_COST
268 size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
269 size_up (SCC lbl body)
270 = if scc_s_OK then size_up body else Nothing
272 size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing
274 size_up (Con con args) = -- 1 + # of val args
275 sizeN (1 + numValArgs args)
276 size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
278 op_cost = if primOpCanTriggerGC op
279 then uNFOLDING_DEAR_OP_COST
280 -- these *tend* to be more expensive;
281 -- number chosen to avoid unfolding (HACK)
282 else uNFOLDING_CHEAP_OP_COST
284 size_up expr@(Lam _ _)
286 (uvars, tyvars, args, body) = collectBinders expr
288 size_up body `addSizeN` length args
290 size_up (Let (NonRec binder rhs) body)
297 size_up (Let (Rec pairs) body)
298 = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]
304 size_up (Case scrut alts)
305 = size_up_scrut scrut
307 size_up_alts (coreExprType scrut) alts
308 -- We charge for the "case" itself in "size_up_alts"
311 size_up_arg arg = if isValArg arg then sizeOne else sizeZero{-it's free-}
314 size_up_alts scrut_ty (AlgAlts alts deflt)
315 = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts
316 `addSizeN` (if is_data then tyConFamilySize tycon else 1{-??-})
317 -- NB: we charge N for an alg. "case", where N is
318 -- the number of constructors in the thing being eval'd.
319 -- (You'll eventually get a "discount" of N if you
320 -- think the "case" is likely to go away.)
322 size_alg_alt (con,args,rhs) = size_up rhs
323 -- Don't charge for args, so that wrappers look cheap
326 = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $
327 case (maybeAppDataTyConExpandingDicts scrut_ty) of
328 Nothing -> (False, panic "size_up_alts")
329 Just (tc,_,_) -> (True, tc)
331 size_up_alts _ (PrimAlts alts deflt)
332 = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
333 -- *no charge* for a primitive "case"!
335 size_prim_alt (lit,rhs) = size_up rhs
338 size_up_deflt NoDefault = sizeZero
339 size_up_deflt (BindDefault binder rhs) = size_up rhs
342 -- Scrutinees. There are two things going on here.
343 -- First, we want to record if we're case'ing an argument
344 -- Second, we want to charge nothing for the srutinee if it's just
345 -- a variable. That way wrapper-like things look cheap.
346 size_up_scrut (Var v) | v `is_elem` args = Just (0, [v])
347 | otherwise = Just (0, [])
348 size_up_scrut other = size_up other
350 is_elem :: Id -> [Id] -> Bool
351 is_elem = isIn "size_up_scrut"
354 sizeZero = Just (0, [])
355 sizeOne = Just (1, [])
356 sizeN n = Just (n, [])
358 addSizeN Nothing _ = Nothing
359 addSizeN (Just (n, xs)) m
360 | tot < bOMB_OUT_SIZE = Just (tot, xs)
361 | otherwise = Nothing
365 addSize Nothing _ = Nothing
366 addSize _ Nothing = Nothing
367 addSize (Just (n, xs)) (Just (m, ys))
368 | tot < bOMB_OUT_SIZE = Just (tot, xys)
369 | otherwise = Nothing
375 %************************************************************************
377 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
379 %************************************************************************
381 We have very limited information about an unfolding expression: (1)~so
382 many type arguments and so many value arguments expected---for our
383 purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
384 a single integer. (3)~An ``argument info'' vector. For this, what we
385 have at the moment is a Boolean per argument position that says, ``I
386 will look with great favour on an explicit constructor in this
389 Assuming we have enough type- and value arguments (if not, we give up
390 immediately), then we see if the ``discounted size'' is below some
391 (semi-arbitrary) threshold. It works like this: for every argument
392 position where we're looking for a constructor AND WE HAVE ONE in our
393 hands, we get a (again, semi-arbitrary) discount [proportion to the
394 number of constructors in the type being scrutinized].
397 smallEnoughToInline :: Int -> Int -- Constructor discount and size threshold
398 -> [Bool] -- Evaluated-ness of value arguments
400 -> Bool -- True => unfold it
402 smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True
403 smallEnoughToInline con_discount size_threshold _ UnfoldNever = False
404 smallEnoughToInline con_discount size_threshold arg_is_evald_s
405 (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
406 = n_vals_wanted <= length arg_is_evald_s &&
407 discounted_size <= size_threshold
410 discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
412 arg_discount no_of_constrs is_evald
413 | is_evald = 1 + no_of_constrs * con_discount
417 We use this one to avoid exporting inlinings that we ``couldn't possibly
418 use'' on the other side. Can be overridden w/ flaggery.
419 Just the same as smallEnoughToInline, except that it has no actual arguments.
422 couldBeSmallEnoughToInline :: Int -> Int -- Constructor discount and size threshold
424 -> Bool -- True => unfold it
426 couldBeSmallEnoughToInline con_discount size_threshold guidance
427 = smallEnoughToInline con_discount size_threshold (repeat True) guidance
430 %************************************************************************
432 \subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces}
434 %************************************************************************
436 Of course, the main thing we do to unfoldings-for-interfaces is {\em
437 print} them. But, while we're at it, we collect info about
438 ``mentioned'' Ids, etc., etc.---we're going to need this stuff anyway.
440 %************************************************************************
442 \subsubsection{Monad stuff for the unfolding-generation game}
444 %************************************************************************
447 type UnfoldM bndr thing
448 = IdSet -- in-scope Ids (passed downwards only)
449 -> (bndr -> Id) -- to extract an Id from a binder (down only)
451 -> (Bag Id, -- mentioned global vars (ditto)
452 Bag TyCon, -- ditto, tycons
453 Bag Class, -- ditto, classes
454 Bool) -- True <=> mentions something litlit-ish
456 -> (thing, (Bag Id, Bag TyCon, Bag Class, Bool)) -- accumulated...
459 A little stuff for in-scopery:
461 no_in_scopes :: IdSet
462 add1 :: IdSet -> Id -> IdSet
463 add_some :: IdSet -> [Id] -> IdSet
465 no_in_scopes = emptyUniqSet
466 in_scopes `add1` x = addOneToUniqSet in_scopes x
467 in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs
470 The can-see-inside-monad functions are the usual sorts of things.
473 thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b
474 thenUf m k in_scopes get_id mentioneds
475 = case m in_scopes get_id mentioneds of { (v, mentioneds1) ->
476 k v in_scopes get_id mentioneds1 }
478 thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b
479 thenUf_ m k in_scopes get_id mentioneds
480 = case m in_scopes get_id mentioneds of { (_, mentioneds1) ->
481 k in_scopes get_id mentioneds1 }
483 mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b]
484 mapUf f [] = returnUf []
486 = f x `thenUf` \ r ->
487 mapUf f xs `thenUf` \ rs ->
490 returnUf :: a -> UnfoldM bndr a
491 returnUf v in_scopes get_id mentioneds = (v, mentioneds)
493 addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a
494 addInScopesUf more_in_scopes m in_scopes get_id mentioneds
495 = m (in_scopes `add_some` more_in_scopes) get_id mentioneds
497 getInScopesUf :: UnfoldM bndr IdSet
498 getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds)
500 extractIdsUf :: [bndr] -> UnfoldM bndr [Id]
501 extractIdsUf binders in_scopes get_id mentioneds
502 = (map get_id binders, mentioneds)
504 consider_Id :: Id -> UnfoldM bndr ()
505 consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit)
507 (ids2, tcs2, clss2) = whatsMentionedInId in_scopes var
509 ((), (ids `unionBags` ids2,
510 tcs `unionBags` tcs2,
511 clss `unionBags`clss2,
516 addToMentionedIdsUf :: Id -> UnfoldM bndr ()
517 addToMentionedTyConsUf :: Bag TyCon -> UnfoldM bndr ()
518 addToMentionedClassesUf :: Bag Class -> UnfoldM bndr ()
519 litlit_oops :: UnfoldM bndr ()
521 addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit)
522 = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit))
524 addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
525 = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit))
527 addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
528 = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit))
530 litlit_oops in_scopes get_id (ids, tcs, clss, _)
531 = ((), (ids, tcs, clss, True))
535 %************************************************************************
537 \subsubsection{Gathering up info for an interface-unfolding}
539 %************************************************************************
544 :: (bndr -> Id) -- so we can get Ids out of binders
545 -> GenCoreExpr bndr Id -- input expression
546 -> (Bag Id, Bag TyCon, Bag Class,
547 -- what we found mentioned in the expr
548 Bool -- True <=> mentions a ``litlit''-ish thing
549 -- (the guy on the other side of an interface
550 -- may not be able to handle it)
554 mentionedInUnfolding get_id expr
555 = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of
556 (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) ->
557 (ids_bag, tcs_bag, clss_bag, has_litlit)
561 --ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr ()
563 ment_expr (Var v) = consider_Id v
564 ment_expr (Lit l) = consider_lit l
566 ment_expr expr@(Lam _ _)
568 (uvars, tyvars, args, body) = collectBinders expr
570 extractIdsUf args `thenUf` \ bs_ids ->
571 addInScopesUf bs_ids (
572 -- this considering is just to extract any mentioned types/classes
573 mapUf consider_Id bs_ids `thenUf_`
577 ment_expr (App fun arg)
578 = ment_expr fun `thenUf_`
582 = consider_Id c `thenUf_`
583 mapUf ment_arg as `thenUf_`
586 ment_expr (Prim op as)
587 = ment_op op `thenUf_`
588 mapUf ment_arg as `thenUf_`
591 ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
592 = mapUf ment_ty arg_tys `thenUf_`
594 ment_op other_op = returnUf ()
596 ment_expr (Case scrutinee alts)
597 = ment_expr scrutinee `thenUf_`
600 ment_expr (Let (NonRec bind rhs) body)
601 = ment_expr rhs `thenUf_`
602 extractIdsUf [bind] `thenUf` \ bi@[bind_id] ->
604 ment_expr body `thenUf_`
605 consider_Id bind_id )
607 ment_expr (Let (Rec pairs) body)
609 binders = map fst pairs
612 extractIdsUf binders `thenUf` \ binder_ids ->
613 addInScopesUf binder_ids (
614 mapUf ment_expr rhss `thenUf_`
615 mapUf consider_Id binder_ids `thenUf_`
618 ment_expr (SCC cc expr)
619 = (case (ccMentionsId cc) of
620 Just id -> consider_Id id
621 Nothing -> returnUf ()
623 `thenUf_` ment_expr expr
625 ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
630 (tycons, clss) = getMentionedTyConsAndClassesFromType ty
632 addToMentionedTyConsUf tycons `thenUf_`
633 addToMentionedClassesUf clss
637 ment_alts alg_alts@(AlgAlts alts deflt)
638 = mapUf ment_alt alts `thenUf_`
641 ment_alt alt@(con, params, rhs)
642 = consider_Id con `thenUf_`
643 extractIdsUf params `thenUf` \ param_ids ->
644 addInScopesUf param_ids (
645 -- "consider" them so we can chk out their types...
646 mapUf consider_Id param_ids `thenUf_`
649 ment_alts (PrimAlts alts deflt)
650 = mapUf ment_alt alts `thenUf_`
653 ment_alt alt@(lit, rhs) = ment_expr rhs
659 ment_deflt d@(BindDefault b rhs)
660 = extractIdsUf [b] `thenUf` \ bi@[b_id] ->
662 consider_Id b_id `thenUf_`
666 ment_arg (VarArg v) = consider_Id v
667 ment_arg (LitArg l) = consider_lit l
668 ment_arg (TyArg ty) = ment_ty ty
669 ment_arg (UsageArg _) = returnUf ()
673 | isLitLitLit lit = litlit_oops `thenUf_` returnUf ()
674 | otherwise = returnUf ()
677 %************************************************************************
679 \subsubsection{Printing unfoldings in interfaces}
681 %************************************************************************
683 Printing Core-expression unfoldings is sufficiently delicate that we
684 give it its own function.
691 pprCoreUnfolding expr
693 (_, renamed) = instCoreExpr uniqSupply_u expr
694 -- We rename every unfolding with a "steady" unique supply,
695 -- so that the names won't constantly change.
696 -- One place we *MUST NOT* use a splittable UniqueSupply!
698 ppr_uf_Expr emptyUniqSet renamed
700 ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding")
704 ppr_uf_Expr in_scopes (Var v) = pprIdInUnfolding in_scopes v
705 ppr_uf_Expr in_scopes (Lit l) = ppr ppr_Unfolding l
707 ppr_uf_Expr in_scopes (Con c as)
708 = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP,
709 ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
710 ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
711 ppr_uf_Expr in_scopes (Prim op as)
712 = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP,
713 ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
714 ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
716 ppr_uf_Expr in_scopes (Lam binder body)
717 = ppCat [ppChar '\\', ppr_uf_Binder binder,
718 ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add1` binder) body]
720 ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
721 = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->",
722 ppr_uf_Expr in_scopes body]
724 (tyvars, body) = collect_tyvars expr
726 collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after )
727 where (tyvs, e_after) = collect_tyvars e
728 collect_tyvars other_e = ( [], other_e )
730 ppr_uf_Expr in_scopes expr@(App fun_expr atom)
732 (fun, args) = collect_args expr []
734 ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack,
735 ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack]
737 collect_args (App fun arg) args = collect_args fun (arg:args)
738 collect_args fun args = (fun, args)
740 ppr_uf_Expr in_scopes (CoTyApp expr ty)
741 = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr,
742 ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}']
744 ppr_uf_Expr in_scopes (Case scrutinee alts)
745 = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
746 pp_alts alts, ppChar '}']
748 pp_alts (AlgAlts alts deflt)
749 = ppCat [ppPStr SLIT("_ALG_"), ppCat (map pp_alg alts), pp_deflt deflt]
750 pp_alts (PrimAlts alts deflt)
751 = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
753 pp_alg (con, params, rhs)
754 = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP,
755 ppIntersperse ppSP (map ppr_uf_Binder params),
756 ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi]
759 = ppBesides [ppr ppr_Unfolding lit,
760 ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
762 pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_")
763 pp_deflt (BindDefault binder rhs)
764 = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
765 ppr_uf_Expr (in_scopes `add1` binder) rhs]
767 ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body)
768 = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
769 ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
771 ppr_uf_Expr in_scopes (Let (Rec pairs) body)
772 = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
773 ppStr "} in ", ppr_uf_Expr new_in_scopes body]
775 sep = ppBeside ppSemi ppSP
776 new_in_scopes = in_scopes `add_some` map fst pairs
778 pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
780 ppr_uf_Expr in_scopes (SCC cc body)
781 = ASSERT(not (noCostCentreAttached cc))
782 ASSERT(not (currentOrSubsumedCosts cc))
783 ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ", ppr_uf_Expr in_scopes body]
785 ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce"
789 ppr_uf_Binder :: Id -> Pretty
791 = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "),
792 ppr ppr_Unfolding (idType v), ppRparen]
794 ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l
795 ppr_uf_Atom in_scopes (VarArg v) = pprIdInUnfolding in_scopes v