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