Remove unused LiveVars and SRT fields of StgCase and StgLetNoEscape
[ghc.git] / compiler / stgSyn / StgSyn.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
5
6 This data type represents programs just before code generation (conversion to
7 @Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
8 being one that happens to be ideally suited to spineless tagless code
9 generation.
10 -}
11
12 {-# LANGUAGE CPP #-}
13
14 module StgSyn (
15 GenStgArg(..),
16 GenStgLiveVars,
17
18 GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
19 GenStgAlt, AltType(..),
20
21 UpdateFlag(..), isUpdatable,
22
23 StgBinderInfo,
24 noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
25 combineStgBinderInfo,
26
27 -- a set of synonyms for the most common (only :-) parameterisation
28 StgArg, StgLiveVars,
29 StgBinding, StgExpr, StgRhs, StgAlt,
30
31 -- StgOp
32 StgOp(..),
33
34 -- utils
35 stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
36 isDllConApp,
37 stgArgType,
38 stripStgTicksTop,
39
40 pprStgBinding, pprStgBindings,
41 pprStgLVs
42 ) where
43
44 #include "HsVersions.h"
45
46 import CoreSyn ( AltCon, Tickish )
47 import CostCentre ( CostCentreStack )
48 import Data.List ( intersperse )
49 import DataCon
50 import DynFlags
51 import FastString
52 import ForeignCall ( ForeignCall )
53 import Id
54 import IdInfo ( mayHaveCafRefs )
55 import Literal ( Literal, literalType )
56 import Module ( Module )
57 import Outputable
58 import Packages ( isDllName )
59 import Platform
60 import PprCore ( {- instances -} )
61 import PrimOp ( PrimOp, PrimCall )
62 import TyCon ( PrimRep(..) )
63 import TyCon ( TyCon )
64 import Type ( Type )
65 import Type ( typePrimRep )
66 import UniqSet
67 import Unique ( Unique )
68 import Util
69
70 {-
71 ************************************************************************
72 * *
73 \subsection{@GenStgBinding@}
74 * *
75 ************************************************************************
76
77 As usual, expressions are interesting; other things are boring. Here
78 are the boring things [except note the @GenStgRhs@], parameterised
79 with respect to binder and occurrence information (just as in
80 @CoreSyn@):
81 -}
82
83 data GenStgBinding bndr occ
84 = StgNonRec bndr (GenStgRhs bndr occ)
85 | StgRec [(bndr, GenStgRhs bndr occ)]
86
87 {-
88 ************************************************************************
89 * *
90 \subsection{@GenStgArg@}
91 * *
92 ************************************************************************
93 -}
94
95 data GenStgArg occ
96 = StgVarArg occ
97 | StgLitArg Literal
98
99 -- | Does this constructor application refer to
100 -- anything in a different *Windows* DLL?
101 -- If so, we can't allocate it statically
102 isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
103 isDllConApp dflags this_mod con args
104 | platformOS (targetPlatform dflags) == OSMinGW32
105 = isDllName dflags this_pkg this_mod (dataConName con) || any is_dll_arg args
106 | otherwise = False
107 where
108 -- NB: typePrimRep is legit because any free variables won't have
109 -- unlifted type (there are no unlifted things at top level)
110 is_dll_arg :: StgArg -> Bool
111 is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v))
112 && isDllName dflags this_pkg this_mod (idName v)
113 is_dll_arg _ = False
114
115 this_pkg = thisPackage dflags
116
117 -- True of machine addresses; these are the things that don't
118 -- work across DLLs. The key point here is that VoidRep comes
119 -- out False, so that a top level nullary GADT constructor is
120 -- False for isDllConApp
121 -- data T a where
122 -- T1 :: T Int
123 -- gives
124 -- T1 :: forall a. (a~Int) -> T a
125 -- and hence the top-level binding
126 -- $WT1 :: T Int
127 -- $WT1 = T1 Int (Coercion (Refl Int))
128 -- The coercion argument here gets VoidRep
129 isAddrRep :: PrimRep -> Bool
130 isAddrRep AddrRep = True
131 isAddrRep PtrRep = True
132 isAddrRep _ = False
133
134 -- | Type of an @StgArg@
135 --
136 -- Very half baked becase we have lost the type arguments.
137 stgArgType :: StgArg -> Type
138 stgArgType (StgVarArg v) = idType v
139 stgArgType (StgLitArg lit) = literalType lit
140
141
142 -- | Strip ticks of a given type from an STG expression
143 stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr)
144 stripStgTicksTop p = go []
145 where go ts (StgTick t e) | p t = go (t:ts) e
146 go ts other = (reverse ts, other)
147
148
149 {-
150 ************************************************************************
151 * *
152 \subsection{STG expressions}
153 * *
154 ************************************************************************
155
156 The @GenStgExpr@ data type is parameterised on binder and occurrence
157 info, as before.
158
159 ************************************************************************
160 * *
161 \subsubsection{@GenStgExpr@ application}
162 * *
163 ************************************************************************
164
165 An application is of a function to a list of atoms [not expressions].
166 Operationally, we want to push the arguments on the stack and call the
167 function. (If the arguments were expressions, we would have to build
168 their closures first.)
169
170 There is no constructor for a lone variable; it would appear as
171 @StgApp var []@.
172 -}
173
174 type GenStgLiveVars occ = UniqSet occ
175
176 data GenStgExpr bndr occ
177 = StgApp
178 occ -- function
179 [GenStgArg occ] -- arguments; may be empty
180
181 {-
182 ************************************************************************
183 * *
184 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
185 * *
186 ************************************************************************
187
188 There are specialised forms of application, for constructors,
189 primitives, and literals.
190 -}
191
192 | StgLit Literal
193
194 -- StgConApp is vital for returning unboxed tuples
195 -- which can't be let-bound first
196 | StgConApp DataCon
197 [GenStgArg occ] -- Saturated
198
199 | StgOpApp StgOp -- Primitive op or foreign call
200 [GenStgArg occ] -- Saturated
201 Type -- Result type
202 -- We need to know this so that we can
203 -- assign result registers
204
205 {-
206 ************************************************************************
207 * *
208 \subsubsection{@StgLam@}
209 * *
210 ************************************************************************
211
212 StgLam is used *only* during CoreToStg's work. Before CoreToStg has
213 finished it encodes (\x -> e) as (let f = \x -> e in f)
214 -}
215
216 | StgLam
217 [bndr]
218 StgExpr -- Body of lambda
219
220 {-
221 ************************************************************************
222 * *
223 \subsubsection{@GenStgExpr@: case-expressions}
224 * *
225 ************************************************************************
226
227 This has the same boxed/unboxed business as Core case expressions.
228 -}
229
230 | StgCase
231 (GenStgExpr bndr occ)
232 -- the thing to examine
233
234 bndr -- binds the result of evaluating the scrutinee
235
236 AltType
237
238 [GenStgAlt bndr occ]
239 -- The DEFAULT case is always *first*
240 -- if it is there at all
241
242 {-
243 ************************************************************************
244 * *
245 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
246 * *
247 ************************************************************************
248
249 The various forms of let(rec)-expression encode most of the
250 interesting things we want to do.
251 \begin{enumerate}
252 \item
253 \begin{verbatim}
254 let-closure x = [free-vars] [args] expr
255 in e
256 \end{verbatim}
257 is equivalent to
258 \begin{verbatim}
259 let x = (\free-vars -> \args -> expr) free-vars
260 \end{verbatim}
261 \tr{args} may be empty (and is for most closures). It isn't under
262 circumstances like this:
263 \begin{verbatim}
264 let x = (\y -> y+z)
265 \end{verbatim}
266 This gets mangled to
267 \begin{verbatim}
268 let-closure x = [z] [y] (y+z)
269 \end{verbatim}
270 The idea is that we compile code for @(y+z)@ in an environment in which
271 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
272 offset from the stack pointer.
273
274 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
275
276 \item
277 \begin{verbatim}
278 let-constructor x = Constructor [args]
279 in e
280 \end{verbatim}
281
282 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
283
284 \item
285 Letrec-expressions are essentially the same deal as
286 let-closure/let-constructor, so we use a common structure and
287 distinguish between them with an @is_recursive@ boolean flag.
288
289 \item
290 \begin{verbatim}
291 let-unboxed u = an arbitrary arithmetic expression in unboxed values
292 in e
293 \end{verbatim}
294 All the stuff on the RHS must be fully evaluated.
295 No function calls either!
296
297 (We've backed away from this toward case-expressions with
298 suitably-magical alts ...)
299
300 \item
301 ~[Advanced stuff here! Not to start with, but makes pattern matching
302 generate more efficient code.]
303
304 \begin{verbatim}
305 let-escapes-not fail = expr
306 in e'
307 \end{verbatim}
308 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
309 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
310 Rather than build a closure for @fail@, all we need do is to record the stack
311 level at the moment of the @let-escapes-not@; then entering @fail@ is just
312 a matter of adjusting the stack pointer back down to that point and entering
313 the code for it.
314
315 Another example:
316 \begin{verbatim}
317 f x y = let z = huge-expression in
318 if y==1 then z else
319 if y==2 then z else
320 1
321 \end{verbatim}
322
323 (A let-escapes-not is an @StgLetNoEscape@.)
324
325 \item
326 We may eventually want:
327 \begin{verbatim}
328 let-literal x = Literal
329 in e
330 \end{verbatim}
331 \end{enumerate}
332
333 And so the code for let(rec)-things:
334 -}
335
336 | StgLet
337 (GenStgBinding bndr occ) -- right hand sides (see below)
338 (GenStgExpr bndr occ) -- body
339
340 | StgLetNoEscape
341 (GenStgBinding bndr occ) -- right hand sides (see below)
342 (GenStgExpr bndr occ) -- body
343
344 {-
345 %************************************************************************
346 %* *
347 \subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
348 %* *
349 %************************************************************************
350
351 Finally for @hpc@ expressions we introduce a new STG construct.
352 -}
353
354 | StgTick
355 (Tickish bndr)
356 (GenStgExpr bndr occ) -- sub expression
357
358 -- END of GenStgExpr
359
360 {-
361 ************************************************************************
362 * *
363 \subsection{STG right-hand sides}
364 * *
365 ************************************************************************
366
367 Here's the rest of the interesting stuff for @StgLet@s; the first
368 flavour is for closures:
369 -}
370
371 data GenStgRhs bndr occ
372 = StgRhsClosure
373 CostCentreStack -- CCS to be attached (default is CurrentCCS)
374 StgBinderInfo -- Info about how this binder is used (see below)
375 [occ] -- non-global free vars; a list, rather than
376 -- a set, because order is important
377 !UpdateFlag -- ReEntrant | Updatable | SingleEntry
378 [bndr] -- arguments; if empty, then not a function;
379 -- as above, order is important.
380 (GenStgExpr bndr occ) -- body
381
382 {-
383 An example may be in order. Consider:
384 \begin{verbatim}
385 let t = \x -> \y -> ... x ... y ... p ... q in e
386 \end{verbatim}
387 Pulling out the free vars and stylising somewhat, we get the equivalent:
388 \begin{verbatim}
389 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
390 \end{verbatim}
391 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
392 offsets from @Node@ into the closure, and the code ptr for the closure
393 will be exactly that in parentheses above.
394
395 The second flavour of right-hand-side is for constructors (simple but important):
396 -}
397
398 | StgRhsCon
399 CostCentreStack -- CCS to be attached (default is CurrentCCS).
400 -- Top-level (static) ones will end up with
401 -- DontCareCCS, because we don't count static
402 -- data in heap profiles, and we don't set CCCS
403 -- from static closure.
404 DataCon -- constructor
405 [GenStgArg occ] -- args
406
407 stgRhsArity :: StgRhs -> Int
408 stgRhsArity (StgRhsClosure _ _ _ _ bndrs _)
409 = ASSERT( all isId bndrs ) length bndrs
410 -- The arity never includes type parameters, but they should have gone by now
411 stgRhsArity (StgRhsCon _ _ _) = 0
412
413 -- Note [CAF consistency]
414 -- ~~~~~~~~~~~~~~~~~~~~~~
415 --
416 -- `stgBindHasCafRefs` and `rhsHasCafRefs` are only used by an assert
417 -- (`consistentCafInfo` in `CoreToStg`) to make sure CAF-ness predicted by
418 -- `TidyPgm` is consistent with reality.
419 --
420 -- Specifically, if the RHS mentions any Id that itself is marked
421 -- `MayHaveCafRefs`; or if the binding is an updateable thunk; then the `Id` for
422 -- the binding should be marked `MayHaveCafRefs`. The potential trouble is that
423 -- `TidyPgm` computed the CAF info on the `Id` but some transformations have
424 -- taken place since then.
425
426 stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
427 stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
428 stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds)
429
430 rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
431 rhsHasCafRefs (StgRhsClosure _ _ _ upd _ body)
432 = -- See Note [CAF consistency]
433 isUpdatable upd || exprHasCafRefs body
434 rhsHasCafRefs (StgRhsCon _ _ args)
435 = any stgArgHasCafRefs args
436
437 exprHasCafRefs :: GenStgExpr bndr Id -> Bool
438 exprHasCafRefs (StgApp f args)
439 = mayHaveCafRefs (idCafInfo f) || any stgArgHasCafRefs args
440 exprHasCafRefs StgLit{}
441 = False
442 exprHasCafRefs (StgConApp _ args)
443 = any stgArgHasCafRefs args
444 exprHasCafRefs (StgOpApp _ args _)
445 = any stgArgHasCafRefs args
446 exprHasCafRefs (StgLam _ body)
447 = exprHasCafRefs body
448 exprHasCafRefs (StgCase scrt _ _ alts)
449 = exprHasCafRefs scrt || any altHasCafRefs alts
450 exprHasCafRefs (StgLet bind body)
451 = stgBindHasCafRefs bind || exprHasCafRefs body
452 exprHasCafRefs (StgLetNoEscape bind body)
453 = stgBindHasCafRefs bind || exprHasCafRefs body
454 exprHasCafRefs (StgTick _ expr)
455 = exprHasCafRefs expr
456
457 altHasCafRefs :: GenStgAlt bndr Id -> Bool
458 altHasCafRefs (_, _, _, rhs) = exprHasCafRefs rhs
459
460 stgArgHasCafRefs :: GenStgArg Id -> Bool
461 stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
462 stgArgHasCafRefs _ = False
463
464 -- Here's the @StgBinderInfo@ type, and its combining op:
465
466 data StgBinderInfo
467 = NoStgBinderInfo
468 | SatCallsOnly -- All occurrences are *saturated* *function* calls
469 -- This means we don't need to build an info table and
470 -- slow entry code for the thing
471 -- Thunks never get this value
472
473 noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
474 noBinderInfo = NoStgBinderInfo
475 stgUnsatOcc = NoStgBinderInfo
476 stgSatOcc = SatCallsOnly
477
478 satCallsOnly :: StgBinderInfo -> Bool
479 satCallsOnly SatCallsOnly = True
480 satCallsOnly NoStgBinderInfo = False
481
482 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
483 combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
484 combineStgBinderInfo _ _ = NoStgBinderInfo
485
486 --------------
487 pp_binder_info :: StgBinderInfo -> SDoc
488 pp_binder_info NoStgBinderInfo = empty
489 pp_binder_info SatCallsOnly = text "sat-only"
490
491 {-
492 ************************************************************************
493 * *
494 \subsection[Stg-case-alternatives]{STG case alternatives}
495 * *
496 ************************************************************************
497
498 Very like in @CoreSyntax@ (except no type-world stuff).
499
500 The type constructor is guaranteed not to be abstract; that is, we can
501 see its representation. This is important because the code generator
502 uses it to determine return conventions etc. But it's not trivial
503 where there's a module loop involved, because some versions of a type
504 constructor might not have all the constructors visible. So
505 mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
506 constructors or literals (which are guaranteed to have the Real McCoy)
507 rather than from the scrutinee type.
508 -}
509
510 type GenStgAlt bndr occ
511 = (AltCon, -- alts: data constructor,
512 [bndr], -- constructor's parameters,
513 [Bool], -- "use mask", same length as
514 -- parameters; a True in a
515 -- param's position if it is
516 -- used in the ...
517 GenStgExpr bndr occ) -- ...right-hand side.
518
519 data AltType
520 = PolyAlt -- Polymorphic (a type variable)
521 | UbxTupAlt Int -- Unboxed tuple of this arity
522 | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts
523 | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts
524
525 {-
526 ************************************************************************
527 * *
528 \subsection[Stg]{The Plain STG parameterisation}
529 * *
530 ************************************************************************
531
532 This happens to be the only one we use at the moment.
533 -}
534
535 type StgBinding = GenStgBinding Id Id
536 type StgArg = GenStgArg Id
537 type StgLiveVars = GenStgLiveVars Id
538 type StgExpr = GenStgExpr Id Id
539 type StgRhs = GenStgRhs Id Id
540 type StgAlt = GenStgAlt Id Id
541
542 {-
543 ************************************************************************
544 * *
545 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
546 * *
547 ************************************************************************
548
549 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
550
551 A @ReEntrant@ closure may be entered multiple times, but should not be
552 updated or blackholed. An @Updatable@ closure should be updated after
553 evaluation (and may be blackholed during evaluation). A @SingleEntry@
554 closure will only be entered once, and so need not be updated but may
555 safely be blackholed.
556 -}
557
558 data UpdateFlag = ReEntrant | Updatable | SingleEntry
559
560 instance Outputable UpdateFlag where
561 ppr u = char $ case u of
562 ReEntrant -> 'r'
563 Updatable -> 'u'
564 SingleEntry -> 's'
565
566 isUpdatable :: UpdateFlag -> Bool
567 isUpdatable ReEntrant = False
568 isUpdatable SingleEntry = False
569 isUpdatable Updatable = True
570
571 {-
572 ************************************************************************
573 * *
574 \subsubsection{StgOp}
575 * *
576 ************************************************************************
577
578 An StgOp allows us to group together PrimOps and ForeignCalls.
579 It's quite useful to move these around together, notably
580 in StgOpApp and COpStmt.
581 -}
582
583 data StgOp
584 = StgPrimOp PrimOp
585
586 | StgPrimCallOp PrimCall
587
588 | StgFCallOp ForeignCall Unique
589 -- The Unique is occasionally needed by the C pretty-printer
590 -- (which lacks a unique supply), notably when generating a
591 -- typedef for foreign-export-dynamic
592
593 {-
594 ************************************************************************
595 * *
596 \subsection[Stg-pretty-printing]{Pretty-printing}
597 * *
598 ************************************************************************
599
600 Robin Popplestone asked for semi-colon separators on STG binds; here's
601 hoping he likes terminators instead... Ditto for case alternatives.
602 -}
603
604 pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
605 => GenStgBinding bndr bdee -> SDoc
606
607 pprGenStgBinding (StgNonRec bndr rhs)
608 = hang (hsep [pprBndr LetBind bndr, equals])
609 4 (ppr rhs <> semi)
610
611 pprGenStgBinding (StgRec pairs)
612 = vcat $ ifPprDebug (text "{- StgRec (begin) -}") :
613 map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")]
614 where
615 ppr_bind (bndr, expr)
616 = hang (hsep [pprBndr LetBind bndr, equals])
617 4 (ppr expr <> semi)
618
619 pprStgBinding :: StgBinding -> SDoc
620 pprStgBinding bind = pprGenStgBinding bind
621
622 pprStgBindings :: [StgBinding] -> SDoc
623 pprStgBindings binds = vcat $ intersperse blankLine (map pprGenStgBinding binds)
624
625 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
626 ppr = pprStgArg
627
628 instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
629 => Outputable (GenStgBinding bndr bdee) where
630 ppr = pprGenStgBinding
631
632 instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
633 => Outputable (GenStgExpr bndr bdee) where
634 ppr = pprStgExpr
635
636 instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
637 => Outputable (GenStgRhs bndr bdee) where
638 ppr rhs = pprStgRhs rhs
639
640 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
641 pprStgArg (StgVarArg var) = ppr var
642 pprStgArg (StgLitArg con) = ppr con
643
644 pprStgExpr :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
645 => GenStgExpr bndr bdee -> SDoc
646 -- special case
647 pprStgExpr (StgLit lit) = ppr lit
648
649 -- general case
650 pprStgExpr (StgApp func args)
651 = hang (ppr func) 4 (sep (map (ppr) args))
652
653 pprStgExpr (StgConApp con args)
654 = hsep [ ppr con, brackets (interppSP args)]
655
656 pprStgExpr (StgOpApp op args _)
657 = hsep [ pprStgOp op, brackets (interppSP args)]
658
659 pprStgExpr (StgLam bndrs body)
660 = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) bndrs)
661 <+> text "->",
662 pprStgExpr body ]
663 where ppr_list = brackets . fsep . punctuate comma
664
665 -- special case: let v = <very specific thing>
666 -- in
667 -- let ...
668 -- in
669 -- ...
670 --
671 -- Very special! Suspicious! (SLPJ)
672
673 {-
674 pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
675 expr@(StgLet _ _))
676 = ($$)
677 (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
678 ppr cc,
679 pp_binder_info bi,
680 text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),
681 ppr upd_flag, text " [",
682 interppSP args, char ']'])
683 8 (sep [hsep [ppr rhs, text "} in"]]))
684 (ppr expr)
685 -}
686
687 -- special case: let ... in let ...
688
689 pprStgExpr (StgLet bind expr@(StgLet _ _))
690 = ($$)
691 (sep [hang (text "let {")
692 2 (hsep [pprGenStgBinding bind, text "} in"])])
693 (ppr expr)
694
695 -- general case
696 pprStgExpr (StgLet bind expr)
697 = sep [hang (text "let {") 2 (pprGenStgBinding bind),
698 hang (text "} in ") 2 (ppr expr)]
699
700 pprStgExpr (StgLetNoEscape bind expr)
701 = sep [hang (text "let-no-escape {")
702 2 (pprGenStgBinding bind),
703 hang (text "} in ")
704 2 (ppr expr)]
705
706 pprStgExpr (StgTick tickish expr)
707 = sdocWithDynFlags $ \dflags ->
708 if gopt Opt_PprShowTicks dflags
709 then sep [ ppr tickish, pprStgExpr expr ]
710 else pprStgExpr expr
711
712
713 pprStgExpr (StgCase expr bndr alt_type alts)
714 = sep [sep [text "case",
715 nest 4 (hsep [pprStgExpr expr,
716 ifPprDebug (dcolon <+> ppr alt_type)]),
717 text "of", pprBndr CaseBind bndr, char '{'],
718 nest 2 (vcat (map pprStgAlt alts)),
719 char '}']
720
721 pprStgAlt :: (OutputableBndr bndr, Outputable occ, Ord occ)
722 => GenStgAlt bndr occ -> SDoc
723 pprStgAlt (con, params, _use_mask, expr)
724 = hang (hsep [ppr con, sep (map (pprBndr CaseBind) params), text "->"])
725 4 (ppr expr <> semi)
726
727 pprStgOp :: StgOp -> SDoc
728 pprStgOp (StgPrimOp op) = ppr op
729 pprStgOp (StgPrimCallOp op)= ppr op
730 pprStgOp (StgFCallOp op _) = ppr op
731
732 instance Outputable AltType where
733 ppr PolyAlt = text "Polymorphic"
734 ppr (UbxTupAlt n) = text "UbxTup" <+> ppr n
735 ppr (AlgAlt tc) = text "Alg" <+> ppr tc
736 ppr (PrimAlt tc) = text "Prim" <+> ppr tc
737
738 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
739 pprStgLVs lvs
740 = getPprStyle $ \ sty ->
741 if userStyle sty || isEmptyUniqSet lvs then
742 empty
743 else
744 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
745
746 pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
747 => GenStgRhs bndr bdee -> SDoc
748
749 -- special case
750 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
751 = hcat [ ppr cc,
752 pp_binder_info bi,
753 brackets (ifPprDebug (ppr free_var)),
754 text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
755
756 -- general case
757 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
758 = sdocWithDynFlags $ \dflags ->
759 hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
760 pp_binder_info bi,
761 ifPprDebug (brackets (interppSP free_vars)),
762 char '\\' <> ppr upd_flag, brackets (interppSP args)])
763 4 (ppr body)
764
765 pprStgRhs (StgRhsCon cc con args)
766 = hcat [ ppr cc,
767 space, ppr con, text "! ", brackets (interppSP args)]