Some DEBUG CPP removal
[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         (GenStgExpr bndr occ)   -- scc expression
378 \end{code}
379
380 %************************************************************************
381 %*                                                                      *
382 \subsubsection{@GenStgExpr@: @hpc@ expressions}
383 %*                                                                      *
384 %************************************************************************
385
386 Finally for @scc@ expressions we introduce a new STG construct.
387
388 \begin{code}
389   | StgTick
390     Module                      -- the module of the source of this tick
391     Int                         -- tick number
392     (GenStgExpr bndr occ)       -- sub expression
393   -- end of GenStgExpr
394 \end{code}
395
396 %************************************************************************
397 %*                                                                      *
398 \subsection{STG right-hand sides}
399 %*                                                                      *
400 %************************************************************************
401
402 Here's the rest of the interesting stuff for @StgLet@s; the first
403 flavour is for closures:
404 \begin{code}
405 data GenStgRhs bndr occ
406   = StgRhsClosure
407         CostCentreStack         -- CCS to be attached (default is CurrentCCS)
408         StgBinderInfo           -- Info about how this binder is used (see below)
409         [occ]                   -- non-global free vars; a list, rather than
410                                 -- a set, because order is important
411         !UpdateFlag             -- ReEntrant | Updatable | SingleEntry
412         SRT                     -- The SRT reference
413         [bndr]                  -- arguments; if empty, then not a function;
414                                 -- as above, order is important.
415         (GenStgExpr bndr occ)   -- body
416 \end{code}
417 An example may be in order.  Consider:
418 \begin{verbatim}
419 let t = \x -> \y -> ... x ... y ... p ... q in e
420 \end{verbatim}
421 Pulling out the free vars and stylising somewhat, we get the equivalent:
422 \begin{verbatim}
423 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
424 \end{verbatim}
425 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
426 offsets from @Node@ into the closure, and the code ptr for the closure
427 will be exactly that in parentheses above.
428
429 The second flavour of right-hand-side is for constructors (simple but important):
430 \begin{code}
431   | StgRhsCon
432         CostCentreStack         -- CCS to be attached (default is CurrentCCS).
433                                 -- Top-level (static) ones will end up with
434                                 -- DontCareCCS, because we don't count static
435                                 -- data in heap profiles, and we don't set CCCS
436                                 -- from static closure.
437         DataCon                 -- constructor
438         [GenStgArg occ] -- args
439 \end{code}
440
441 \begin{code}
442 stgRhsArity :: StgRhs -> Int
443 stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) 
444   = ASSERT( all isId bndrs ) length bndrs
445   -- The arity never includes type parameters, but they should have gone by now
446 stgRhsArity (StgRhsCon _ _ _) = 0
447 \end{code}
448
449 \begin{code}
450 stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
451 stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
452 stgBindHasCafRefs (StgRec binds)    = any rhsHasCafRefs (map snd binds)
453
454 rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
455 rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) 
456   = isUpdatable upd || nonEmptySRT srt
457 rhsHasCafRefs (StgRhsCon _ _ args)
458   = any stgArgHasCafRefs args
459
460 stgArgHasCafRefs :: GenStgArg Id -> Bool
461 stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
462 stgArgHasCafRefs _ = False
463 \end{code}
464
465 Here's the @StgBinderInfo@ type, and its combining op:
466 \begin{code}
467 data StgBinderInfo
468   = NoStgBinderInfo
469   | SatCallsOnly        -- All occurrences are *saturated* *function* calls
470                         -- This means we don't need to build an info table and 
471                         -- slow entry code for the thing
472                         -- Thunks never get this value
473
474 noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo
475 noBinderInfo = NoStgBinderInfo
476 stgUnsatOcc  = NoStgBinderInfo
477 stgSatOcc    = SatCallsOnly
478
479 satCallsOnly :: StgBinderInfo -> Bool
480 satCallsOnly SatCallsOnly    = True
481 satCallsOnly NoStgBinderInfo = False
482
483 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
484 combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
485 combineStgBinderInfo _            _            = NoStgBinderInfo
486
487 --------------
488 pp_binder_info :: StgBinderInfo -> SDoc
489 pp_binder_info NoStgBinderInfo = empty
490 pp_binder_info SatCallsOnly    = ptext (sLit "sat-only")
491 \end{code}
492
493 %************************************************************************
494 %*                                                                      *
495 \subsection[Stg-case-alternatives]{STG case alternatives}
496 %*                                                                      *
497 %************************************************************************
498
499 Very like in @CoreSyntax@ (except no type-world stuff).
500
501 The type constructor is guaranteed not to be abstract; that is, we can
502 see its representation.  This is important because the code generator
503 uses it to determine return conventions etc.  But it's not trivial
504 where there's a moduule loop involved, because some versions of a type
505 constructor might not have all the constructors visible.  So
506 mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
507 constructors or literals (which are guaranteed to have the Real McCoy)
508 rather than from the scrutinee type.
509
510 \begin{code}
511 type GenStgAlt bndr occ
512   = (AltCon,            -- alts: data constructor,
513      [bndr],            -- constructor's parameters,
514      [Bool],            -- "use mask", same length as
515                         -- parameters; a True in a
516                         -- param's position if it is
517                         -- used in the ...
518      GenStgExpr bndr occ)       -- ...right-hand side.
519
520 data AltType
521   = PolyAlt             -- Polymorphic (a type variable)
522   | UbxTupAlt TyCon     -- Unboxed tuple
523   | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
524   | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
525 \end{code}
526
527 %************************************************************************
528 %*                                                                      *
529 \subsection[Stg]{The Plain STG parameterisation}
530 %*                                                                      *
531 %************************************************************************
532
533 This happens to be the only one we use at the moment.
534
535 \begin{code}
536 type StgBinding     = GenStgBinding     Id Id
537 type StgArg         = GenStgArg         Id
538 type StgLiveVars    = GenStgLiveVars    Id
539 type StgExpr        = GenStgExpr        Id Id
540 type StgRhs         = GenStgRhs         Id Id
541 type StgAlt         = GenStgAlt         Id Id
542 \end{code}
543
544 %************************************************************************
545 %*                                                                      *
546 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
547 %*                                                                      *
548 %************************************************************************
549
550 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
551
552 A @ReEntrant@ closure may be entered multiple times, but should not be
553 updated or blackholed.  An @Updatable@ closure should be updated after
554 evaluation (and may be blackholed during evaluation).  A @SingleEntry@
555 closure will only be entered once, and so need not be updated but may
556 safely be blackholed.
557
558 \begin{code}
559 data UpdateFlag = ReEntrant | Updatable | SingleEntry
560
561 instance Outputable UpdateFlag where
562     ppr u
563       = char (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
564
565 isUpdatable :: UpdateFlag -> Bool
566 isUpdatable ReEntrant   = False
567 isUpdatable SingleEntry = False
568 isUpdatable Updatable   = True
569 \end{code}
570
571 %************************************************************************
572 %*                                                                      *
573 \subsubsection{StgOp}
574 %*                                                                      *
575 %************************************************************************
576
577 An StgOp allows us to group together PrimOps and ForeignCalls.
578 It's quite useful to move these around together, notably
579 in StgOpApp and COpStmt.
580
581 \begin{code}
582 data StgOp = StgPrimOp  PrimOp
583
584            | StgPrimCallOp PrimCall
585
586            | StgFCallOp ForeignCall Unique
587                 -- The Unique is occasionally needed by the C pretty-printer
588                 -- (which lacks a unique supply), notably when generating a
589                 -- typedef for foreign-export-dynamic
590 \end{code}
591
592
593 %************************************************************************
594 %*                                                                      *
595 \subsubsection[Static Reference Tables]{@SRT@}
596 %*                                                                      *
597 %************************************************************************
598
599 There is one SRT per top-level function group.  Each local binding and
600 case expression within this binding group has a subrange of the whole
601 SRT, expressed as an offset and length.
602
603 In CoreToStg we collect the list of CafRefs at each SRT site, which is later 
604 converted into the length and offset form by the SRT pass.
605
606 \begin{code}
607 data SRT = NoSRT
608          | SRTEntries IdSet
609                 -- generated by CoreToStg
610          | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
611                 -- generated by computeSRTs
612
613 nonEmptySRT :: SRT -> Bool
614 nonEmptySRT NoSRT           = False
615 nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
616 nonEmptySRT _               = True
617
618 pprSRT :: SRT -> SDoc
619 pprSRT (NoSRT)          = ptext (sLit "_no_srt_")
620 pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
621 pprSRT (SRT off _ _)    = parens (ppr off <> comma <> text "*bitmap*")
622 \end{code}
623
624 %************************************************************************
625 %*                                                                      *
626 \subsection[Stg-pretty-printing]{Pretty-printing}
627 %*                                                                      *
628 %************************************************************************
629
630 Robin Popplestone asked for semi-colon separators on STG binds; here's
631 hoping he likes terminators instead...  Ditto for case alternatives.
632
633 \begin{code}
634 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
635                  => GenStgBinding bndr bdee -> SDoc
636
637 pprGenStgBinding (StgNonRec bndr rhs)
638   = hang (hsep [ppr bndr, equals])
639         4 ((<>) (ppr rhs) semi)
640
641 pprGenStgBinding (StgRec pairs)
642   = vcat ((ifPprDebug (ptext (sLit "{- StgRec (begin) -}"))) :
643            (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext (sLit "{- StgRec (end) -}")))])
644   where
645     ppr_bind (bndr, expr)
646       = hang (hsep [ppr bndr, equals])
647              4 ((<>) (ppr expr) semi)
648
649 pprStgBinding  :: StgBinding -> SDoc
650 pprStgBinding  bind  = pprGenStgBinding bind
651
652 pprStgBindings :: [StgBinding] -> SDoc
653 pprStgBindings binds = vcat (map pprGenStgBinding binds)
654
655 pprGenStgBindingWithSRT  
656         :: (Outputable bndr, Outputable bdee, Ord bdee) 
657         => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
658
659 pprGenStgBindingWithSRT (bind,srts)
660   = vcat (pprGenStgBinding bind : map pprSRT srts)
661   where pprSRT (id,srt) = 
662            ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt
663
664 pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
665 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
666 \end{code}
667
668 \begin{code}
669 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
670     ppr = pprStgArg
671
672 instance (Outputable bndr, Outputable bdee, Ord bdee)
673                 => Outputable (GenStgBinding bndr bdee) where
674     ppr = pprGenStgBinding
675
676 instance (Outputable bndr, Outputable bdee, Ord bdee)
677                 => Outputable (GenStgExpr bndr bdee) where
678     ppr = pprStgExpr
679
680 instance (Outputable bndr, Outputable bdee, Ord bdee)
681                 => Outputable (GenStgRhs bndr bdee) where
682     ppr rhs = pprStgRhs rhs
683 \end{code}
684
685 \begin{code}
686 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
687
688 pprStgArg (StgVarArg var) = ppr var
689 pprStgArg (StgLitArg con) = ppr con
690 pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty
691 \end{code}
692
693 \begin{code}
694 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
695            => GenStgExpr bndr bdee -> SDoc
696 -- special case
697 pprStgExpr (StgLit lit)     = ppr lit
698
699 -- general case
700 pprStgExpr (StgApp func args)
701   = hang (ppr func)
702          4 (sep (map (ppr) args))
703 \end{code}
704
705 \begin{code}
706 pprStgExpr (StgConApp con args)
707   = hsep [ ppr con, brackets (interppSP args)]
708
709 pprStgExpr (StgOpApp op args _)
710   = hsep [ pprStgOp op, brackets (interppSP args)]
711
712 pprStgExpr (StgLam _ bndrs body)
713   =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"),
714          pprStgExpr body ]
715 \end{code}
716
717 \begin{code}
718 -- special case: let v = <very specific thing>
719 --               in
720 --               let ...
721 --               in
722 --               ...
723 --
724 -- Very special!  Suspicious! (SLPJ)
725
726 {-
727 pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
728                         expr@(StgLet _ _))
729   = ($$)
730       (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "),
731                           ppr cc,
732                           pp_binder_info bi,
733                           ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"),
734                           ppr upd_flag, ptext (sLit " ["),
735                           interppSP args, char ']'])
736             8 (sep [hsep [ppr rhs, ptext (sLit "} in")]]))
737       (ppr expr)
738 -}
739
740 -- special case: let ... in let ...
741
742 pprStgExpr (StgLet bind expr@(StgLet _ _))
743   = ($$)
744       (sep [hang (ptext (sLit "let {"))
745                 2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])])
746       (ppr expr)
747
748 -- general case
749 pprStgExpr (StgLet bind expr)
750   = sep [hang (ptext (sLit "let {")) 2 (pprGenStgBinding bind),
751            hang (ptext (sLit "} in ")) 2 (ppr expr)]
752
753 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
754   = sep [hang (ptext (sLit "let-no-escape {"))
755                 2 (pprGenStgBinding bind),
756            hang ((<>) (ptext (sLit "} in "))
757                    (ifPprDebug (
758                     nest 4 (
759                       hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
760                              ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
761                              char ']']))))
762                 2 (ppr expr)]
763
764 pprStgExpr (StgSCC cc expr)
765   = sep [ hsep [ptext (sLit "_scc_"), ppr cc],
766           pprStgExpr expr ]
767
768 pprStgExpr (StgTick m n expr)
769   = sep [ hsep [ptext (sLit "_tick_"),  pprModule m,text (show n)],
770           pprStgExpr expr ]
771
772 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
773   = sep [sep [ptext (sLit "case"),
774            nest 4 (hsep [pprStgExpr expr,
775              ifPprDebug (dcolon <+> ppr alt_type)]),
776            ptext (sLit "of"), ppr bndr, char '{'],
777            ifPprDebug (
778            nest 4 (
779              hcat [ptext  (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
780                     ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
781                     ptext (sLit "]; "),
782                     pprMaybeSRT srt])),
783            nest 2 (vcat (map pprStgAlt alts)),
784            char '}']
785
786 pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ)
787           => GenStgAlt bndr occ -> SDoc
788 pprStgAlt (con, params, _use_mask, expr)
789   = hang (hsep [ppr con, interppSP params, ptext (sLit "->")])
790          4 (ppr expr <> semi)
791
792 pprStgOp :: StgOp -> SDoc
793 pprStgOp (StgPrimOp  op)   = ppr op
794 pprStgOp (StgPrimCallOp op)= ppr op
795 pprStgOp (StgFCallOp op _) = ppr op
796
797 instance Outputable AltType where
798   ppr PolyAlt        = ptext (sLit "Polymorphic")
799   ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc
800   ppr (AlgAlt tc)    = ptext (sLit "Alg")    <+> ppr tc
801   ppr (PrimAlt tc)   = ptext (sLit "Prim")   <+> ppr tc
802 \end{code}
803
804 \begin{code}
805 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
806 pprStgLVs lvs
807   = getPprStyle $ \ sty ->
808     if userStyle sty || isEmptyUniqSet lvs then
809         empty
810     else
811         hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
812 \end{code}
813
814 \begin{code}
815 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
816           => GenStgRhs bndr bdee -> SDoc
817
818 -- special case
819 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
820   = hcat [ ppr cc,
821            pp_binder_info bi,
822            brackets (ifPprDebug (ppr free_var)),
823            ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
824
825 -- general case
826 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
827   = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
828                 pp_binder_info bi,
829                 ifPprDebug (brackets (interppSP free_vars)),
830                 char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
831          4 (ppr body)
832
833 pprStgRhs (StgRhsCon cc con args)
834   = hcat [ ppr cc,
835            space, ppr con, ptext (sLit "! "), brackets (interppSP args)]
836
837 pprMaybeSRT :: SRT -> SDoc
838 pprMaybeSRT (NoSRT) = empty
839 pprMaybeSRT srt     = ptext (sLit "srt:") <> pprSRT srt
840 \end{code}