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