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