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