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