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