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