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