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