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