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