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