2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
6 This data type represents programs just before code generation
7 (conversion to @AbstractC@): basically, what we have is a stylised
8 form of @CoreSyntax@, the style being one that happens to be ideally
9 suited to spineless tagless code generation.
16 GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
17 GenStgCaseAlts(..), GenStgCaseDefault(..),
19 UpdateFlag(..), isUpdatable,
22 noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
25 -- a set of synonyms for the most common (only :-) parameterisation
27 StgBinding, StgExpr, StgRhs,
28 StgCaseAlts, StgCaseDefault,
34 stgBindHasCafRefs, stgRhsArity, getArgPrimRep,
35 isLitLitArg, isDllConApp, isStgTypeArg,
36 stgArgType, stgBinders,
38 pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts
45 #include "HsVersions.h"
47 import CostCentre ( CostCentreStack, CostCentre )
48 import VarSet ( IdSet, isEmptyVarSet )
49 import Id ( Id, idName, idPrimRep, idType )
50 import Name ( isDllName )
51 import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
52 import DataCon ( DataCon, dataConName )
53 import PrimOp ( PrimOp )
56 import TyCon ( TyCon )
57 import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
58 import CmdLineOpts ( opt_SccProfilingOn )
61 %************************************************************************
63 \subsection{@GenStgBinding@}
65 %************************************************************************
67 As usual, expressions are interesting; other things are boring. Here
68 are the boring things [except note the @GenStgRhs@], parameterised
69 with respect to binder and occurrence information (just as in
72 There is one SRT for each group of bindings.
75 data GenStgBinding bndr occ
76 = StgNonRec SRT bndr (GenStgRhs bndr occ)
77 | StgRec SRT [(bndr, GenStgRhs bndr occ)]
79 stgBinders :: GenStgBinding bndr occ -> [bndr]
80 stgBinders (StgNonRec _ b _) = [b]
81 stgBinders (StgRec _ bs) = map fst bs
84 %************************************************************************
86 \subsection{@GenStgArg@}
88 %************************************************************************
94 | StgTypeArg Type -- For when we want to preserve all type info
98 getArgPrimRep (StgVarArg local) = idPrimRep local
99 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
101 isLitLitArg (StgLitArg lit) = isLitLitLit lit
102 isLitLitArg _ = False
104 isStgTypeArg (StgTypeArg _) = True
105 isStgTypeArg other = False
107 isDllArg :: StgArg -> Bool
108 -- Does this argument refer to something in a different DLL?
109 isDllArg (StgVarArg v) = isDllName (idName v)
110 isDllArg (StgLitArg lit) = isLitLitLit lit
112 isDllConApp :: DataCon -> [StgArg] -> Bool
113 -- Does this constructor application refer to
114 -- anything in a different DLL?
115 -- If so, we can't allocate it statically
116 isDllConApp con args = isDllName (dataConName con) || any isDllArg args
118 stgArgType :: StgArg -> Type
119 -- Very half baked becase we have lost the type arguments
120 stgArgType (StgVarArg v) = idType v
121 stgArgType (StgLitArg lit) = literalType lit
124 %************************************************************************
126 \subsection{STG expressions}
128 %************************************************************************
130 The @GenStgExpr@ data type is parameterised on binder and occurrence
133 %************************************************************************
135 \subsubsection{@GenStgExpr@ application}
137 %************************************************************************
139 An application is of a function to a list of atoms [not expressions].
140 Operationally, we want to push the arguments on the stack and call the
141 function. (If the arguments were expressions, we would have to build
142 their closures first.)
144 There is no constructor for a lone variable; it would appear as
147 type GenStgLiveVars occ = UniqSet occ
149 data GenStgExpr bndr occ
152 [GenStgArg occ] -- arguments; may be empty
155 %************************************************************************
157 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
159 %************************************************************************
161 There are a specialised forms of application, for
162 constructors, primitives, and literals.
167 [GenStgArg occ] -- Saturated
170 [GenStgArg occ] -- Saturated
171 Type -- Result type; we need to know the result type
172 -- so that we can assign result registers.
175 %************************************************************************
177 \subsubsection{@StgLam@}
179 %************************************************************************
181 StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished
182 it encodes (\x -> e) as (let f = \x -> e in f)
186 Type -- Type of whole lambda (useful when making a binder for it)
188 StgExpr -- Body of lambda
192 %************************************************************************
194 \subsubsection{@GenStgExpr@: case-expressions}
196 %************************************************************************
198 This has the same boxed/unboxed business as Core case expressions.
201 (GenStgExpr bndr occ)
202 -- the thing to examine
204 (GenStgLiveVars occ) -- Live vars of whole case
205 -- expression; i.e., those which mustn't be
208 (GenStgLiveVars occ) -- Live vars of RHSs;
209 -- i.e., those which must be saved before eval.
211 -- note that an alt's constructor's
212 -- binder-variables are NOT counted in the
213 -- free vars for the alt's RHS
215 bndr -- binds the result of evaluating the scrutinee
217 SRT -- The SRT for the continuation
219 (GenStgCaseAlts bndr occ)
222 %************************************************************************
224 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
226 %************************************************************************
228 The various forms of let(rec)-expression encode most of the
229 interesting things we want to do.
233 let-closure x = [free-vars] expr [args]
238 let x = (\free-vars -> \args -> expr) free-vars
240 \tr{args} may be empty (and is for most closures). It isn't under
241 circumstances like this:
247 let-closure x = [z] [y] (y+z)
249 The idea is that we compile code for @(y+z)@ in an environment in which
250 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
251 offset from the stack pointer.
253 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
257 let-constructor x = Constructor [args]
261 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
264 Letrec-expressions are essentially the same deal as
265 let-closure/let-constructor, so we use a common structure and
266 distinguish between them with an @is_recursive@ boolean flag.
270 let-unboxed u = an arbitrary arithmetic expression in unboxed values
273 All the stuff on the RHS must be fully evaluated. No function calls either!
275 (We've backed away from this toward case-expressions with
276 suitably-magical alts ...)
279 ~[Advanced stuff here! Not to start with, but makes pattern matching
280 generate more efficient code.]
283 let-escapes-not fail = expr
286 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
287 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
288 Rather than build a closure for @fail@, all we need do is to record the stack
289 level at the moment of the @let-escapes-not@; then entering @fail@ is just
290 a matter of adjusting the stack pointer back down to that point and entering
295 f x y = let z = huge-expression in
301 (A let-escapes-not is an @StgLetNoEscape@.)
304 We may eventually want:
306 let-literal x = Literal
310 (ToDo: is this obsolete?)
313 And so the code for let(rec)-things:
316 (GenStgBinding bndr occ) -- right hand sides (see below)
317 (GenStgExpr bndr occ) -- body
319 | StgLetNoEscape -- remember: ``advanced stuff''
320 (GenStgLiveVars occ) -- Live in the whole let-expression
321 -- Mustn't overwrite these stack slots
322 -- *Doesn't* include binders of the let(rec).
324 (GenStgLiveVars occ) -- Live in the right hand sides (only)
325 -- These are the ones which must be saved on
326 -- the stack if they aren't there already
327 -- *Does* include binders of the let(rec) if recursive.
329 (GenStgBinding bndr occ) -- right hand sides (see below)
330 (GenStgExpr bndr occ) -- body
333 %************************************************************************
335 \subsubsection{@GenStgExpr@: @scc@ expressions}
337 %************************************************************************
339 Finally for @scc@ expressions we introduce a new STG construct.
343 CostCentre -- label of SCC expression
344 (GenStgExpr bndr occ) -- scc expression
348 %************************************************************************
350 \subsection{STG right-hand sides}
352 %************************************************************************
354 Here's the rest of the interesting stuff for @StgLet@s; the first
355 flavour is for closures:
357 data GenStgRhs bndr occ
359 CostCentreStack -- CCS to be attached (default is CurrentCCS)
360 StgBinderInfo -- Info about how this binder is used (see below)
361 [occ] -- non-global free vars; a list, rather than
362 -- a set, because order is important
363 !UpdateFlag -- ReEntrant | Updatable | SingleEntry
364 [bndr] -- arguments; if empty, then not a function;
365 -- as above, order is important.
366 (GenStgExpr bndr occ) -- body
368 An example may be in order. Consider:
370 let t = \x -> \y -> ... x ... y ... p ... q in e
372 Pulling out the free vars and stylising somewhat, we get the equivalent:
374 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
376 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
377 offsets from @Node@ into the closure, and the code ptr for the closure
378 will be exactly that in parentheses above.
380 The second flavour of right-hand-side is for constructors (simple but important):
383 CostCentreStack -- CCS to be attached (default is CurrentCCS).
384 -- Top-level (static) ones will end up with
385 -- DontCareCCS, because we don't count static
386 -- data in heap profiles, and we don't set CCCS
387 -- from static closure.
388 DataCon -- constructor
389 [GenStgArg occ] -- args
393 stgRhsArity :: GenStgRhs bndr occ -> Int
394 stgRhsArity (StgRhsClosure _ _ _ _ args _) = length args
395 stgRhsArity (StgRhsCon _ _ _) = 0
399 stgBindHasCafRefs :: GenStgBinding bndr occ -> Bool
400 stgBindHasCafRefs (StgNonRec srt _ rhs)
401 = nonEmptySRT srt || rhsIsUpdatable rhs
402 stgBindHasCafRefs (StgRec srt binds)
403 = nonEmptySRT srt || any rhsIsUpdatable (map snd binds)
405 rhsIsUpdatable (StgRhsClosure _ _ _ upd _ _) = isUpdatable upd
406 rhsIsUpdatable _ = False
409 Here's the @StgBinderInfo@ type, and its combining op:
413 | SatCallsOnly -- All occurrences are *saturated* *function* calls
414 -- This means we don't need to build an info table and
415 -- slow entry code for the thing
416 -- Thunks never get this value
418 noBinderInfo = NoStgBinderInfo
419 stgUnsatOcc = NoStgBinderInfo
420 stgSatOcc = SatCallsOnly
422 satCallsOnly :: StgBinderInfo -> Bool
423 satCallsOnly SatCallsOnly = True
424 satCallsOnly NoStgBinderInfo = False
426 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
427 combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
428 combineStgBinderInfo info1 info2 = NoStgBinderInfo
431 pp_binder_info NoStgBinderInfo = empty
432 pp_binder_info SatCallsOnly = ptext SLIT("sat-only")
435 %************************************************************************
437 \subsection[Stg-case-alternatives]{STG case alternatives}
439 %************************************************************************
441 Just like in @CoreSyntax@ (except no type-world stuff).
443 * Algebraic cases are done using
444 StgAlgAlts (Just tc) alts deflt
446 * Polymorphic cases, or case of a function type, are done using
447 StgAlgAlts Nothing [] (StgBindDefault e)
449 * Primitive cases are done using
450 StgPrimAlts tc alts deflt
452 We thought of giving polymorphic cases their own constructor,
453 but we get a bit more code sharing this way
455 The type constructor in StgAlgAlts/StgPrimAlts is guaranteed not
456 to be abstract; that is, we can see its representation. This is
457 important because the code generator uses it to determine return
458 conventions etc. But it's not trivial where there's a moduule loop
459 involved, because some versions of a type constructor might not have
460 all the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures
461 that it gets the TyCon from the constructors or literals (which are
462 guaranteed to have the Real McCoy) rather than from the scrutinee type.
465 data GenStgCaseAlts bndr occ
466 = StgAlgAlts (Maybe TyCon) -- Just tc => scrutinee type is
467 -- an algebraic data type
468 -- Nothing => scrutinee type is a type
469 -- variable or function type
470 [(DataCon, -- alts: data constructor,
471 [bndr], -- constructor's parameters,
472 [Bool], -- "use mask", same length as
473 -- parameters; a True in a
474 -- param's position if it is
476 GenStgExpr bndr occ)] -- ...right-hand side.
477 (GenStgCaseDefault bndr occ)
480 [(Literal, -- alts: unboxed literal,
481 GenStgExpr bndr occ)] -- rhs.
482 (GenStgCaseDefault bndr occ)
484 data GenStgCaseDefault bndr occ
485 = StgNoDefault -- small con family: all
486 -- constructor accounted for
487 | StgBindDefault (GenStgExpr bndr occ)
490 %************************************************************************
492 \subsection[Stg]{The Plain STG parameterisation}
494 %************************************************************************
496 This happens to be the only one we use at the moment.
499 type StgBinding = GenStgBinding Id Id
500 type StgArg = GenStgArg Id
501 type StgLiveVars = GenStgLiveVars Id
502 type StgExpr = GenStgExpr Id Id
503 type StgRhs = GenStgRhs Id Id
504 type StgCaseAlts = GenStgCaseAlts Id Id
505 type StgCaseDefault = GenStgCaseDefault Id Id
508 %************************************************************************
510 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
512 %************************************************************************
514 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
516 A @ReEntrant@ closure may be entered multiple times, but should not be
517 updated or blackholed. An @Updatable@ closure should be updated after
518 evaluation (and may be blackholed during evaluation). A @SingleEntry@
519 closure will only be entered once, and so need not be updated but may
520 safely be blackholed.
523 data UpdateFlag = ReEntrant | Updatable | SingleEntry
525 instance Outputable UpdateFlag where
527 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
529 isUpdatable ReEntrant = False
530 isUpdatable SingleEntry = False
531 isUpdatable Updatable = True
534 %************************************************************************
536 \subsubsection[Static Reference Tables]{@SRT@}
538 %************************************************************************
540 There is one SRT per top-level function group. Each local binding and
541 case expression within this binding group has a subrange of the whole
542 SRT, expressed as an offset and length.
544 In CoreToStg we collect the list of CafRefs at each SRT site, which is later
545 converted into the length and offset form by the SRT pass.
549 | SRTEntries IdSet -- generated by CoreToStg
550 | SRT !Int{-offset-} !Int{-length-} -- generated by computeSRTs
555 nonEmptySRT NoSRT = False
556 nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
559 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
560 pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
561 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
564 %************************************************************************
566 \subsection[Stg-pretty-printing]{Pretty-printing}
568 %************************************************************************
570 Robin Popplestone asked for semi-colon separators on STG binds; here's
571 hoping he likes terminators instead... Ditto for case alternatives.
574 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
575 => GenStgBinding bndr bdee -> SDoc
577 pprGenStgBinding (StgNonRec srt bndr rhs)
578 = pprMaybeSRT srt $$ hang (hsep [ppr bndr, equals])
579 4 ((<>) (ppr rhs) semi)
581 pprGenStgBinding (StgRec srt pairs)
582 = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
584 (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
586 ppr_bind (bndr, expr)
587 = hang (hsep [ppr bndr, equals])
588 4 ((<>) (ppr expr) semi)
590 pprStgBinding :: StgBinding -> SDoc
591 pprStgBinding bind = pprGenStgBinding bind
593 pprStgBindings :: [StgBinding] -> SDoc
594 pprStgBindings binds = vcat (map pprGenStgBinding binds)
596 pprGenStgBindingWithSRT
597 :: (Outputable bndr, Outputable bdee, Ord bdee)
598 => (GenStgBinding bndr bdee,[Id]) -> SDoc
600 pprGenStgBindingWithSRT (bind,srt)
601 = vcat [ pprGenStgBinding bind,
602 ptext SLIT("SRT: ") <> ppr srt ]
604 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
605 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
609 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
612 instance (Outputable bndr, Outputable bdee, Ord bdee)
613 => Outputable (GenStgBinding bndr bdee) where
614 ppr = pprGenStgBinding
616 instance (Outputable bndr, Outputable bdee, Ord bdee)
617 => Outputable (GenStgExpr bndr bdee) where
620 instance (Outputable bndr, Outputable bdee, Ord bdee)
621 => Outputable (GenStgRhs bndr bdee) where
622 ppr rhs = pprStgRhs rhs
626 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
628 pprStgArg (StgVarArg var) = ppr var
629 pprStgArg (StgLitArg con) = ppr con
630 pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty
634 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
635 => GenStgExpr bndr bdee -> SDoc
637 pprStgExpr (StgLit lit) = ppr lit
640 pprStgExpr (StgApp func args)
642 4 (sep (map (ppr) args))
646 pprStgExpr (StgConApp con args)
647 = hsep [ ppr con, brackets (interppSP args)]
649 pprStgExpr (StgPrimApp op args _)
650 = hsep [ ppr op, brackets (interppSP args)]
652 pprStgExpr (StgLam _ bndrs body)
653 =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
658 -- special case: let v = <very specific thing>
664 -- Very special! Suspicious! (SLPJ)
667 pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
670 (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
673 ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
674 ppr upd_flag, ptext SLIT(" ["),
675 interppSP args, char ']'])
676 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
680 -- special case: let ... in let ...
682 pprStgExpr (StgLet bind expr@(StgLet _ _))
684 (sep [hang (ptext SLIT("let {"))
685 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
689 pprStgExpr (StgLet bind expr)
690 = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
691 hang (ptext SLIT("} in ")) 2 (ppr expr)]
693 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
694 = sep [hang (ptext SLIT("let-no-escape {"))
695 2 (pprGenStgBinding bind),
696 hang ((<>) (ptext SLIT("} in "))
699 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
700 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
706 pprStgExpr (StgSCC cc expr)
707 = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
712 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
713 = sep [sep [ptext SLIT("case"),
714 nest 4 (hsep [pprStgExpr expr,
715 ifPprDebug (dcolon <+> pp_ty alts)]),
716 ptext SLIT("of"), ppr bndr, char '{'],
719 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
720 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
723 nest 2 (pprStgAlts alts),
726 pp_ty (StgAlgAlts maybe_tycon _ _) = ppr maybe_tycon
727 pp_ty (StgPrimAlts tycon _ _) = ppr tycon
729 pprStgAlts (StgAlgAlts _ alts deflt)
730 = vcat [ vcat (map (ppr_bxd_alt) alts),
731 pprStgDefault deflt ]
733 ppr_bxd_alt (con, params, use_mask, expr)
734 = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
735 4 ((<>) (ppr expr) semi)
737 pprStgAlts (StgPrimAlts _ alts deflt)
738 = vcat [ vcat (map (ppr_ubxd_alt) alts),
739 pprStgDefault deflt ]
741 ppr_ubxd_alt (lit, expr)
742 = hang (hsep [ppr lit, ptext SLIT("->")])
743 4 ((<>) (ppr expr) semi)
745 pprStgDefault StgNoDefault = empty
746 pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
752 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
754 = getPprStyle $ \ sty ->
755 if userStyle sty || isEmptyUniqSet lvs then
758 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
762 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
763 => GenStgRhs bndr bdee -> SDoc
766 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
769 brackets (ifPprDebug (ppr free_var)),
770 ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
773 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
774 = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
776 ifPprDebug (brackets (interppSP free_vars)),
777 char '\\' <> ppr upd_flag, brackets (interppSP args)])
780 pprStgRhs (StgRhsCon cc con args)
782 space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
784 pprMaybeSRT (NoSRT) = empty
785 pprMaybeSRT srt = ptext SLIT("srt: ") <> pprSRT srt