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