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