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