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