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