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