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