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