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