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 stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc,
23 stgNormalOcc, stgFakeFunAppOcc,
26 -- a set of synonyms for the most common (only :-) parameterisation
28 StgBinding, StgExpr, StgRhs,
29 StgCaseAlts, StgCaseDefault,
34 pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
36 isLitLitArg, isDllConApp, isStgTypeArg,
38 collectFinalStgBinders
45 #include "HsVersions.h"
47 import CostCentre ( CostCentreStack, CostCentre )
48 import Id ( Id, idName, idPrimRep, idType )
49 import Name ( isDllName )
50 import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
51 import DataCon ( DataCon, dataConName )
52 import PrimOp ( PrimOp )
55 import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
58 %************************************************************************
60 \subsection{@GenStgBinding@}
62 %************************************************************************
64 As usual, expressions are interesting; other things are boring. Here
65 are the boring things [except note the @GenStgRhs@], parameterised
66 with respect to binder and occurrence information (just as in
70 data GenStgBinding bndr occ
71 = StgNonRec bndr (GenStgRhs bndr occ)
72 | StgRec [(bndr, GenStgRhs bndr occ)]
75 %************************************************************************
77 \subsection{@GenStgArg@}
79 %************************************************************************
85 | StgTypeArg Type -- For when we want to preserve all type info
89 getArgPrimRep (StgVarArg local) = idPrimRep local
90 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
92 isLitLitArg (StgLitArg lit) = isLitLitLit lit
95 isStgTypeArg (StgTypeArg _) = True
96 isStgTypeArg other = False
98 isDllArg :: StgArg -> Bool
99 -- Does this argument refer to something in a different DLL?
100 isDllArg (StgVarArg v) = isDllName (idName v)
101 isDllArg (StgLitArg lit) = isLitLitLit lit
103 isDllConApp :: DataCon -> [StgArg] -> Bool
104 -- Does this constructor application refer to
105 -- anything in a different DLL?
106 -- If so, we can't allocate it statically
107 isDllConApp con args = isDllName (dataConName con) || any isDllArg args
109 stgArgType :: StgArg -> Type
110 -- Very half baked becase we have lost the type arguments
111 stgArgType (StgVarArg v) = idType v
112 stgArgType (StgLitArg lit) = literalType lit
115 %************************************************************************
117 \subsection{STG expressions}
119 %************************************************************************
121 The @GenStgExpr@ data type is parameterised on binder and occurrence
124 %************************************************************************
126 \subsubsection{@GenStgExpr@ application}
128 %************************************************************************
130 An application is of a function to a list of atoms [not expressions].
131 Operationally, we want to push the arguments on the stack and call the
132 function. (If the arguments were expressions, we would have to build
133 their closures first.)
135 There is no constructor for a lone variable; it would appear as
138 type GenStgLiveVars occ = UniqSet occ
140 data GenStgExpr bndr occ
143 [GenStgArg occ] -- arguments; may be empty
146 %************************************************************************
148 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
150 %************************************************************************
152 There are a specialised forms of application, for
153 constructors, primitives, and literals.
158 [GenStgArg occ] -- Saturated
161 [GenStgArg occ] -- Saturated
162 Type -- Result type; we need to know the result type
163 -- so that we can assign result registers.
166 %************************************************************************
168 \subsubsection{@StgLam@}
170 %************************************************************************
172 StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished
173 it encodes (\x -> e) as (let f = \x -> e in f)
177 Type -- Type of whole lambda (useful when making a binder for it)
179 StgExpr -- Body of lambda
183 %************************************************************************
185 \subsubsection{@GenStgExpr@: case-expressions}
187 %************************************************************************
189 This has the same boxed/unboxed business as Core case expressions.
192 (GenStgExpr bndr occ)
193 -- the thing to examine
195 (GenStgLiveVars occ) -- Live vars of whole case
196 -- expression; i.e., those which mustn't be
199 (GenStgLiveVars occ) -- Live vars of RHSs;
200 -- i.e., those which must be saved before eval.
202 -- note that an alt's constructor's
203 -- binder-variables are NOT counted in the
204 -- free vars for the alt's RHS
206 bndr -- binds the result of evaluating the scrutinee
208 SRT -- The SRT for the continuation
210 (GenStgCaseAlts bndr occ)
213 %************************************************************************
215 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
217 %************************************************************************
219 The various forms of let(rec)-expression encode most of the
220 interesting things we want to do.
224 let-closure x = [free-vars] expr [args]
229 let x = (\free-vars -> \args -> expr) free-vars
231 \tr{args} may be empty (and is for most closures). It isn't under
232 circumstances like this:
238 let-closure x = [z] [y] (y+z)
240 The idea is that we compile code for @(y+z)@ in an environment in which
241 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
242 offset from the stack pointer.
244 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
248 let-constructor x = Constructor [args]
252 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
255 Letrec-expressions are essentially the same deal as
256 let-closure/let-constructor, so we use a common structure and
257 distinguish between them with an @is_recursive@ boolean flag.
261 let-unboxed u = an arbitrary arithmetic expression in unboxed values
264 All the stuff on the RHS must be fully evaluated. No function calls either!
266 (We've backed away from this toward case-expressions with
267 suitably-magical alts ...)
270 ~[Advanced stuff here! Not to start with, but makes pattern matching
271 generate more efficient code.]
274 let-escapes-not fail = expr
277 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
278 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
279 Rather than build a closure for @fail@, all we need do is to record the stack
280 level at the moment of the @let-escapes-not@; then entering @fail@ is just
281 a matter of adjusting the stack pointer back down to that point and entering
286 f x y = let z = huge-expression in
292 (A let-escapes-not is an @StgLetNoEscape@.)
295 We may eventually want:
297 let-literal x = Literal
301 (ToDo: is this obsolete?)
304 And so the code for let(rec)-things:
307 (GenStgBinding bndr occ) -- right hand sides (see below)
308 (GenStgExpr bndr occ) -- body
310 | StgLetNoEscape -- remember: ``advanced stuff''
311 (GenStgLiveVars occ) -- Live in the whole let-expression
312 -- Mustn't overwrite these stack slots
313 -- *Doesn't* include binders of the let(rec).
315 (GenStgLiveVars occ) -- Live in the right hand sides (only)
316 -- These are the ones which must be saved on
317 -- the stack if they aren't there already
318 -- *Does* include binders of the let(rec) if recursive.
320 (GenStgBinding bndr occ) -- right hand sides (see below)
321 (GenStgExpr bndr occ) -- body
324 %************************************************************************
326 \subsubsection{@GenStgExpr@: @scc@ expressions}
328 %************************************************************************
330 Finally for @scc@ expressions we introduce a new STG construct.
334 CostCentre -- label of SCC expression
335 (GenStgExpr bndr occ) -- scc expression
339 %************************************************************************
341 \subsection{STG right-hand sides}
343 %************************************************************************
345 Here's the rest of the interesting stuff for @StgLet@s; the first
346 flavour is for closures:
348 data GenStgRhs bndr occ
350 CostCentreStack -- CCS to be attached (default is CurrentCCS)
351 StgBinderInfo -- Info about how this binder is used (see below)
352 SRT -- The closures's SRT
353 [occ] -- non-global free vars; a list, rather than
354 -- a set, because order is important
355 UpdateFlag -- ReEntrant | Updatable | SingleEntry
356 [bndr] -- arguments; if empty, then not a function;
357 -- as above, order is important.
358 (GenStgExpr bndr occ) -- body
360 An example may be in order. Consider:
362 let t = \x -> \y -> ... x ... y ... p ... q in e
364 Pulling out the free vars and stylising somewhat, we get the equivalent:
366 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
368 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
369 offsets from @Node@ into the closure, and the code ptr for the closure
370 will be exactly that in parentheses above.
372 The second flavour of right-hand-side is for constructors (simple but important):
375 CostCentreStack -- CCS to be attached (default is CurrentCCS).
376 -- Top-level (static) ones will end up with
377 -- DontCareCCS, because we don't count static
378 -- data in heap profiles, and we don't set CCCS
379 -- from static closure.
380 DataCon -- constructor
381 [GenStgArg occ] -- args
384 Here's the @StgBinderInfo@ type, and its combining op:
389 Bool -- At least one occurrence as an argument
391 Bool -- At least one occurrence in an unsaturated application
393 Bool -- This thing (f) has at least occurrence of the form:
394 -- x = [..] \u [] -> f a b c
395 -- where the application is saturated
397 Bool -- Ditto for non-updatable x.
399 Bool -- At least one fake application occurrence, that is
400 -- an StgApp f args where args is an empty list
401 -- This is due to the fact that we do not have a
402 -- StgVar constructor.
403 -- Used by the lambda lifter.
404 -- True => "at least one unsat app" is True too
406 stgArgOcc = StgBinderInfo True False False False False
407 stgUnsatOcc = StgBinderInfo False True False False False
408 stgStdHeapOcc = StgBinderInfo False False True False False
409 stgNoUpdHeapOcc = StgBinderInfo False False False True False
410 stgNormalOcc = StgBinderInfo False False False False False
411 -- [Andre] can't think of a good name for the last one.
412 stgFakeFunAppOcc = StgBinderInfo False True False False True
414 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
416 combineStgBinderInfo NoStgBinderInfo info2 = info2
417 combineStgBinderInfo info1 NoStgBinderInfo = info1
418 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
419 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
420 = StgBinderInfo (arg1 || arg2)
422 (std_heap1 || std_heap2)
423 (upd_heap1 || upd_heap2)
427 %************************************************************************
429 \subsection[Stg-case-alternatives]{STG case alternatives}
431 %************************************************************************
433 Just like in @CoreSyntax@ (except no type-world stuff).
436 data GenStgCaseAlts bndr occ
437 = StgAlgAlts Type -- so we can find out things about constructor family
438 [(DataCon, -- alts: data constructor,
439 [bndr], -- constructor's parameters,
440 [Bool], -- "use mask", same length as
441 -- parameters; a True in a
442 -- param's position if it is
444 GenStgExpr bndr occ)] -- ...right-hand side.
445 (GenStgCaseDefault bndr occ)
446 | StgPrimAlts Type -- so we can find out things about constructor family
447 [(Literal, -- alts: unboxed literal,
448 GenStgExpr bndr occ)] -- rhs.
449 (GenStgCaseDefault bndr occ)
451 data GenStgCaseDefault bndr occ
452 = StgNoDefault -- small con family: all
453 -- constructor accounted for
454 | StgBindDefault (GenStgExpr bndr occ)
457 %************************************************************************
459 \subsection[Stg]{The Plain STG parameterisation}
461 %************************************************************************
463 This happens to be the only one we use at the moment.
466 type StgBinding = GenStgBinding Id Id
467 type StgArg = GenStgArg Id
468 type StgLiveVars = GenStgLiveVars Id
469 type StgExpr = GenStgExpr Id Id
470 type StgRhs = GenStgRhs Id Id
471 type StgCaseAlts = GenStgCaseAlts Id Id
472 type StgCaseDefault = GenStgCaseDefault Id Id
475 %************************************************************************
477 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
479 %************************************************************************
481 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
483 A @ReEntrant@ closure may be entered multiple times, but should not be
484 updated or blackholed. An @Updatable@ closure should be updated after
485 evaluation (and may be blackholed during evaluation). A @SingleEntry@
486 closure will only be entered once, and so need not be updated but may
487 safely be blackholed.
490 data UpdateFlag = ReEntrant | Updatable | SingleEntry
492 instance Outputable UpdateFlag where
494 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
496 isUpdatable ReEntrant = False
497 isUpdatable SingleEntry = False
498 isUpdatable Updatable = True
501 %************************************************************************
503 \subsubsection[Static Reference Tables]{@SRT@}
505 %************************************************************************
507 There is one SRT per top-level function group. Each local binding and
508 case expression within this binding group has a subrange of the whole
509 SRT, expressed as an offset and length.
513 | SRT !Int{-offset-} !Int{-length-}
518 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
519 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
522 %************************************************************************
524 \subsection[Stg-utility-functions]{Utility functions}
526 %************************************************************************
529 For doing interfaces, we want the exported top-level Ids from the
530 final pre-codegen STG code, so as to be sure we have the
531 latest/greatest pragma info.
534 collectFinalStgBinders
535 :: [StgBinding] -- input program
538 collectFinalStgBinders [] = []
539 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
540 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
543 %************************************************************************
545 \subsection[Stg-pretty-printing]{Pretty-printing}
547 %************************************************************************
549 Robin Popplestone asked for semi-colon separators on STG binds; here's
550 hoping he likes terminators instead... Ditto for case alternatives.
553 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
554 => GenStgBinding bndr bdee -> SDoc
556 pprGenStgBinding (StgNonRec bndr rhs)
557 = hang (hsep [ppr bndr, equals])
558 4 ((<>) (ppr rhs) semi)
560 pprGenStgBinding (StgRec pairs)
561 = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
562 (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
564 ppr_bind (bndr, expr)
565 = hang (hsep [ppr bndr, equals])
566 4 ((<>) (ppr expr) semi)
568 pprStgBinding :: StgBinding -> SDoc
569 pprStgBinding bind = pprGenStgBinding bind
571 pprStgBindings :: [StgBinding] -> SDoc
572 pprStgBindings binds = vcat (map pprGenStgBinding binds)
574 pprGenStgBindingWithSRT
575 :: (Outputable bndr, Outputable bdee, Ord bdee)
576 => (GenStgBinding bndr bdee,[Id]) -> SDoc
578 pprGenStgBindingWithSRT (bind,srt)
579 = vcat [ pprGenStgBinding bind,
580 ptext SLIT("SRT: ") <> ppr srt ]
582 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
583 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
587 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
590 instance (Outputable bndr, Outputable bdee, Ord bdee)
591 => Outputable (GenStgBinding bndr bdee) where
592 ppr = pprGenStgBinding
594 instance (Outputable bndr, Outputable bdee, Ord bdee)
595 => Outputable (GenStgExpr bndr bdee) where
598 instance (Outputable bndr, Outputable bdee, Ord bdee)
599 => Outputable (GenStgRhs bndr bdee) where
600 ppr rhs = pprStgRhs rhs
604 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
606 pprStgArg (StgVarArg var) = ppr var
607 pprStgArg (StgLitArg con) = ppr con
608 pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty
612 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
613 => GenStgExpr bndr bdee -> SDoc
615 pprStgExpr (StgLit lit) = ppr lit
618 pprStgExpr (StgApp func args)
620 4 (sep (map (ppr) args))
624 pprStgExpr (StgConApp con args)
625 = hsep [ ppr con, brackets (interppSP args)]
627 pprStgExpr (StgPrimApp op args _)
628 = hsep [ ppr op, brackets (interppSP args)]
630 pprStgExpr (StgLam _ bndrs body)
631 =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
636 -- special case: let v = <very specific thing>
642 -- Very special! Suspicious! (SLPJ)
644 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
647 (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
650 ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
651 ppr upd_flag, ptext SLIT(" ["),
652 interppSP args, char ']'])
653 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
656 -- special case: let ... in let ...
658 pprStgExpr (StgLet bind expr@(StgLet _ _))
660 (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
664 pprStgExpr (StgLet bind expr)
665 = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
666 hang (ptext SLIT("} in ")) 2 (ppr expr)]
668 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
669 = sep [hang (ptext SLIT("let-no-escape {"))
670 2 (pprGenStgBinding bind),
671 hang ((<>) (ptext SLIT("} in "))
674 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
675 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
681 pprStgExpr (StgSCC cc expr)
682 = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
687 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
688 = sep [sep [ptext SLIT("case"),
689 nest 4 (hsep [pprStgExpr expr,
690 ifPprDebug (dcolon <+> pp_ty alts)]),
691 ptext SLIT("of"), ppr bndr, char '{'],
694 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
695 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
698 nest 2 (ppr_alts alts),
701 ppr_default StgNoDefault = empty
702 ppr_default (StgBindDefault expr)
703 = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
705 pp_ty (StgAlgAlts ty _ _) = ppr ty
706 pp_ty (StgPrimAlts ty _ _) = ppr ty
708 ppr_alts (StgAlgAlts ty alts deflt)
709 = vcat [ vcat (map (ppr_bxd_alt) alts),
712 ppr_bxd_alt (con, params, use_mask, expr)
713 = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
714 4 ((<>) (ppr expr) semi)
716 ppr_alts (StgPrimAlts ty alts deflt)
717 = vcat [ vcat (map (ppr_ubxd_alt) alts),
720 ppr_ubxd_alt (lit, expr)
721 = hang (hsep [ppr lit, ptext SLIT("->")])
722 4 ((<>) (ppr expr) semi)
726 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
728 = getPprStyle $ \ sty ->
729 if userStyle sty || isEmptyUniqSet lvs then
732 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
736 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
737 => GenStgRhs bndr bdee -> SDoc
740 pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
744 brackets (ifPprDebug (ppr free_var)),
745 ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
748 pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
749 = hang (hcat [ppr cc,
752 brackets (ifPprDebug (interppSP free_vars)),
753 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
756 pprStgRhs (StgRhsCon cc con args)
758 space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
760 pprMaybeSRT (NoSRT) = empty
761 pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
765 pp_binder_info NoStgBinderInfo = empty
767 -- cases so boring that we print nothing
768 pp_binder_info (StgBinderInfo True b c d e) = empty
771 pp_binder_info (StgBinderInfo a b c d e)
772 = getPprStyle $ \ sty ->
773 if userStyle sty then
776 parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
779 Collect @IdInfo@ stuff that is most easily just snaffled straight
780 from the STG bindings.
783 stgArity :: StgRhs -> Int
785 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
786 stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args