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