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