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