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