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