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, isDynArg, isStgTypeArg,
38 collectFinalStgBinders
45 #include "HsVersions.h"
47 import CostCentre ( CostCentreStack, CostCentre )
48 import Id ( Id, idName, idPrimRep, idType )
49 import Name ( isDynName )
50 import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
51 import DataCon ( DataCon, isDynDataCon, isNullaryDataCon )
52 import PrimOp ( PrimOp )
53 import PrimRep ( PrimRep(..) )
56 import PprType ( {- instance Outputable Type -} )
57 import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
60 %************************************************************************
62 \subsection{@GenStgBinding@}
64 %************************************************************************
66 As usual, expressions are interesting; other things are boring. Here
67 are the boring things [except note the @GenStgRhs@], parameterised
68 with respect to binder and occurrence information (just as in
72 data GenStgBinding bndr occ
73 = StgNonRec bndr (GenStgRhs bndr occ)
74 | StgRec [(bndr, GenStgRhs bndr occ)]
77 %************************************************************************
79 \subsection{@GenStgArg@}
81 %************************************************************************
87 | StgTypeArg Type -- For when we want to preserve all type info
91 getArgPrimRep (StgVarArg local) = idPrimRep local
92 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
94 isLitLitArg (StgLitArg lit) = isLitLitLit lit
97 isStgTypeArg (StgTypeArg _) = True
98 isStgTypeArg other = False
100 isDynArg :: StgArg -> Bool
101 -- Does this argument refer to something in a DLL?
102 isDynArg (StgVarArg v) = isDynName (idName v)
103 isDynArg (StgLitArg lit) = isLitLitLit lit
105 stgArgType :: StgArg -> Type
106 -- Very half baked becase we have lost the type arguments
107 stgArgType (StgVarArg v) = idType v
108 stgArgType (StgLitArg lit) = literalType lit
111 %************************************************************************
113 \subsection{STG expressions}
115 %************************************************************************
117 The @GenStgExpr@ data type is parameterised on binder and occurrence
120 %************************************************************************
122 \subsubsection{@GenStgExpr@ application}
124 %************************************************************************
126 An application is of a function to a list of atoms [not expressions].
127 Operationally, we want to push the arguments on the stack and call the
128 function. (If the arguments were expressions, we would have to build
129 their closures first.)
131 There is no constructor for a lone variable; it would appear as
134 type GenStgLiveVars occ = UniqSet occ
136 data GenStgExpr bndr occ
139 [GenStgArg occ] -- arguments; may be empty
142 %************************************************************************
144 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
146 %************************************************************************
148 There are a specialised forms of application, for
149 constructors, primitives, and literals.
154 [GenStgArg occ] -- Saturated
157 [GenStgArg occ] -- Saturated
158 Type -- Result type; we need to know the result type
159 -- so that we can assign result registers.
162 %************************************************************************
164 \subsubsection{@StgLam@}
166 %************************************************************************
168 StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished
169 it encodes (\x -> e) as (let f = \x -> e in f)
173 Type -- Type of whole lambda (useful when making a binder for it)
175 StgExpr -- Body of lambda
179 %************************************************************************
181 \subsubsection{@GenStgExpr@: case-expressions}
183 %************************************************************************
185 This has the same boxed/unboxed business as Core case expressions.
188 (GenStgExpr bndr occ)
189 -- the thing to examine
191 (GenStgLiveVars occ) -- Live vars of whole case
192 -- expression; i.e., those which mustn't be
195 (GenStgLiveVars occ) -- Live vars of RHSs;
196 -- i.e., those which must be saved before eval.
198 -- note that an alt's constructor's
199 -- binder-variables are NOT counted in the
200 -- free vars for the alt's RHS
202 bndr -- binds the result of evaluating the scrutinee
204 SRT -- The SRT for the continuation
206 (GenStgCaseAlts bndr occ)
209 %************************************************************************
211 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
213 %************************************************************************
215 The various forms of let(rec)-expression encode most of the
216 interesting things we want to do.
220 let-closure x = [free-vars] expr [args]
225 let x = (\free-vars -> \args -> expr) free-vars
227 \tr{args} may be empty (and is for most closures). It isn't under
228 circumstances like this:
234 let-closure x = [z] [y] (y+z)
236 The idea is that we compile code for @(y+z)@ in an environment in which
237 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
238 offset from the stack pointer.
240 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
244 let-constructor x = Constructor [args]
248 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
251 Letrec-expressions are essentially the same deal as
252 let-closure/let-constructor, so we use a common structure and
253 distinguish between them with an @is_recursive@ boolean flag.
257 let-unboxed u = an arbitrary arithmetic expression in unboxed values
260 All the stuff on the RHS must be fully evaluated. No function calls either!
262 (We've backed away from this toward case-expressions with
263 suitably-magical alts ...)
266 ~[Advanced stuff here! Not to start with, but makes pattern matching
267 generate more efficient code.]
270 let-escapes-not fail = expr
273 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
274 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
275 Rather than build a closure for @fail@, all we need do is to record the stack
276 level at the moment of the @let-escapes-not@; then entering @fail@ is just
277 a matter of adjusting the stack pointer back down to that point and entering
282 f x y = let z = huge-expression in
288 (A let-escapes-not is an @StgLetNoEscape@.)
291 We may eventually want:
293 let-literal x = Literal
297 (ToDo: is this obsolete?)
300 And so the code for let(rec)-things:
303 (GenStgBinding bndr occ) -- right hand sides (see below)
304 (GenStgExpr bndr occ) -- body
306 | StgLetNoEscape -- remember: ``advanced stuff''
307 (GenStgLiveVars occ) -- Live in the whole let-expression
308 -- Mustn't overwrite these stack slots
309 -- *Doesn't* include binders of the let(rec).
311 (GenStgLiveVars occ) -- Live in the right hand sides (only)
312 -- These are the ones which must be saved on
313 -- the stack if they aren't there already
314 -- *Does* include binders of the let(rec) if recursive.
316 (GenStgBinding bndr occ) -- right hand sides (see below)
317 (GenStgExpr bndr occ) -- body
320 %************************************************************************
322 \subsubsection{@GenStgExpr@: @scc@ expressions}
324 %************************************************************************
326 Finally for @scc@ expressions we introduce a new STG construct.
330 CostCentre -- label of SCC expression
331 (GenStgExpr bndr occ) -- scc expression
335 %************************************************************************
337 \subsection{STG right-hand sides}
339 %************************************************************************
341 Here's the rest of the interesting stuff for @StgLet@s; the first
342 flavour is for closures:
344 data GenStgRhs bndr occ
346 CostCentreStack -- CCS to be attached (default is CurrentCCS)
347 StgBinderInfo -- Info about how this binder is used (see below)
348 SRT -- The closures's SRT
349 [occ] -- non-global free vars; a list, rather than
350 -- a set, because order is important
351 UpdateFlag -- ReEntrant | Updatable | SingleEntry
352 [bndr] -- arguments; if empty, then not a function;
353 -- as above, order is important.
354 (GenStgExpr bndr occ) -- body
356 An example may be in order. Consider:
358 let t = \x -> \y -> ... x ... y ... p ... q in e
360 Pulling out the free vars and stylising somewhat, we get the equivalent:
362 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
364 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
365 offsets from @Node@ into the closure, and the code ptr for the closure
366 will be exactly that in parentheses above.
368 The second flavour of right-hand-side is for constructors (simple but important):
371 CostCentreStack -- CCS to be attached (default is CurrentCCS).
372 -- Top-level (static) ones will end up with
373 -- DontCareCCS, because we don't count static
374 -- data in heap profiles, and we don't set CCCS
375 -- from static closure.
376 DataCon -- constructor
377 [GenStgArg occ] -- args
380 Here's the @StgBinderInfo@ type, and its combining op:
385 Bool -- At least one occurrence as an argument
387 Bool -- At least one occurrence in an unsaturated application
389 Bool -- This thing (f) has at least occurrence of the form:
390 -- x = [..] \u [] -> f a b c
391 -- where the application is saturated
393 Bool -- Ditto for non-updatable x.
395 Bool -- At least one fake application occurrence, that is
396 -- an StgApp f args where args is an empty list
397 -- This is due to the fact that we do not have a
398 -- StgVar constructor.
399 -- Used by the lambda lifter.
400 -- True => "at least one unsat app" is True too
402 stgArgOcc = StgBinderInfo True False False False False
403 stgUnsatOcc = StgBinderInfo False True False False False
404 stgStdHeapOcc = StgBinderInfo False False True False False
405 stgNoUpdHeapOcc = StgBinderInfo False False False True False
406 stgNormalOcc = StgBinderInfo False False False False False
407 -- [Andre] can't think of a good name for the last one.
408 stgFakeFunAppOcc = StgBinderInfo False True False False True
410 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
412 combineStgBinderInfo NoStgBinderInfo info2 = info2
413 combineStgBinderInfo info1 NoStgBinderInfo = info1
414 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
415 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
416 = StgBinderInfo (arg1 || arg2)
418 (std_heap1 || std_heap2)
419 (upd_heap1 || upd_heap2)
423 %************************************************************************
425 \subsection[Stg-case-alternatives]{STG case alternatives}
427 %************************************************************************
429 Just like in @CoreSyntax@ (except no type-world stuff).
432 data GenStgCaseAlts bndr occ
433 = StgAlgAlts Type -- so we can find out things about constructor family
434 [(DataCon, -- alts: data constructor,
435 [bndr], -- constructor's parameters,
436 [Bool], -- "use mask", same length as
437 -- parameters; a True in a
438 -- param's position if it is
440 GenStgExpr bndr occ)] -- ...right-hand side.
441 (GenStgCaseDefault bndr occ)
442 | StgPrimAlts Type -- so we can find out things about constructor family
443 [(Literal, -- alts: unboxed literal,
444 GenStgExpr bndr occ)] -- rhs.
445 (GenStgCaseDefault bndr occ)
447 data GenStgCaseDefault bndr occ
448 = StgNoDefault -- small con family: all
449 -- constructor accounted for
450 | StgBindDefault (GenStgExpr bndr occ)
453 %************************************************************************
455 \subsection[Stg]{The Plain STG parameterisation}
457 %************************************************************************
459 This happens to be the only one we use at the moment.
462 type StgBinding = GenStgBinding Id Id
463 type StgArg = GenStgArg Id
464 type StgLiveVars = GenStgLiveVars Id
465 type StgExpr = GenStgExpr Id Id
466 type StgRhs = GenStgRhs Id Id
467 type StgCaseAlts = GenStgCaseAlts Id Id
468 type StgCaseDefault = GenStgCaseDefault Id Id
471 %************************************************************************
473 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
475 %************************************************************************
477 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
479 A @ReEntrant@ closure may be entered multiple times, but should not be
480 updated or blackholed. An @Updatable@ closure should be updated after
481 evaluation (and may be blackholed during evaluation). A @SingleEntry@
482 closure will only be entered once, and so need not be updated but may
483 safely be blackholed.
486 data UpdateFlag = ReEntrant | Updatable | SingleEntry
488 instance Outputable UpdateFlag where
490 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
492 isUpdatable ReEntrant = False
493 isUpdatable SingleEntry = False
494 isUpdatable Updatable = True
497 %************************************************************************
499 \subsubsection[Static Reference Tables]{@SRT@}
501 %************************************************************************
503 There is one SRT per top-level function group. Each local binding and
504 case expression within this binding group has a subrange of the whole
505 SRT, expressed as an offset and length.
509 | SRT !Int{-offset-} !Int{-length-}
514 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
515 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
518 %************************************************************************
520 \subsection[Stg-utility-functions]{Utility functions}
522 %************************************************************************
525 For doing interfaces, we want the exported top-level Ids from the
526 final pre-codegen STG code, so as to be sure we have the
527 latest/greatest pragma info.
530 collectFinalStgBinders
531 :: [StgBinding] -- input program
534 collectFinalStgBinders [] = []
535 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
536 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
539 %************************************************************************
541 \subsection[Stg-pretty-printing]{Pretty-printing}
543 %************************************************************************
545 Robin Popplestone asked for semi-colon separators on STG binds; here's
546 hoping he likes terminators instead... Ditto for case alternatives.
549 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
550 => GenStgBinding bndr bdee -> SDoc
552 pprGenStgBinding (StgNonRec bndr rhs)
553 = hang (hsep [ppr bndr, equals])
554 4 ((<>) (ppr rhs) semi)
556 pprGenStgBinding (StgRec pairs)
557 = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
558 (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
560 ppr_bind (bndr, expr)
561 = hang (hsep [ppr bndr, equals])
562 4 ((<>) (ppr expr) semi)
564 pprStgBinding :: StgBinding -> SDoc
565 pprStgBinding bind = pprGenStgBinding bind
567 pprStgBindings :: [StgBinding] -> SDoc
568 pprStgBindings binds = vcat (map pprGenStgBinding binds)
570 pprGenStgBindingWithSRT
571 :: (Outputable bndr, Outputable bdee, Ord bdee)
572 => (GenStgBinding bndr bdee,[Id]) -> SDoc
574 pprGenStgBindingWithSRT (bind,srt)
575 = vcat [ pprGenStgBinding bind,
576 ptext SLIT("SRT: ") <> ppr srt ]
578 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
579 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
583 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
586 instance (Outputable bndr, Outputable bdee, Ord bdee)
587 => Outputable (GenStgBinding bndr bdee) where
588 ppr = pprGenStgBinding
590 instance (Outputable bndr, Outputable bdee, Ord bdee)
591 => Outputable (GenStgExpr bndr bdee) where
594 instance (Outputable bndr, Outputable bdee, Ord bdee)
595 => Outputable (GenStgRhs bndr bdee) where
596 ppr rhs = pprStgRhs rhs
600 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
602 pprStgArg (StgVarArg var) = ppr var
603 pprStgArg (StgLitArg con) = ppr con
604 pprStgARg (StgTypeArg ty) = char '@' <+> ppr ty
608 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
609 => GenStgExpr bndr bdee -> SDoc
611 pprStgExpr (StgLit lit) = ppr lit
614 pprStgExpr (StgApp func args)
616 4 (sep (map (ppr) args))
620 pprStgExpr (StgConApp con args)
621 = hsep [ ppr con, brackets (interppSP args)]
623 pprStgExpr (StgPrimApp op args _)
624 = hsep [ ppr op, brackets (interppSP args)]
626 pprStgExpr (StgLam _ bndrs body)
627 =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
632 -- special case: let v = <very specific thing>
638 -- Very special! Suspicious! (SLPJ)
640 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
643 (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
646 ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
647 ppr upd_flag, ptext SLIT(" ["),
648 interppSP args, char ']'])
649 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
652 -- special case: let ... in let ...
654 pprStgExpr (StgLet bind expr@(StgLet _ _))
656 (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
660 pprStgExpr (StgLet bind expr)
661 = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
662 hang (ptext SLIT("} in ")) 2 (ppr expr)]
664 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
665 = sep [hang (ptext SLIT("let-no-escape {"))
666 2 (pprGenStgBinding bind),
667 hang ((<>) (ptext SLIT("} in "))
670 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
671 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
677 pprStgExpr (StgSCC cc expr)
678 = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
683 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
684 = sep [sep [ptext SLIT("case"),
685 nest 4 (hsep [pprStgExpr expr,
686 ifPprDebug (dcolon <+> pp_ty alts)]),
687 ptext SLIT("of"), ppr bndr, char '{'],
690 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
691 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
694 nest 2 (ppr_alts alts),
697 ppr_default StgNoDefault = empty
698 ppr_default (StgBindDefault expr)
699 = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
701 pp_ty (StgAlgAlts ty _ _) = ppr ty
702 pp_ty (StgPrimAlts ty _ _) = ppr ty
704 ppr_alts (StgAlgAlts ty alts deflt)
705 = vcat [ vcat (map (ppr_bxd_alt) alts),
708 ppr_bxd_alt (con, params, use_mask, expr)
709 = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
710 4 ((<>) (ppr expr) semi)
712 ppr_alts (StgPrimAlts ty alts deflt)
713 = vcat [ vcat (map (ppr_ubxd_alt) alts),
716 ppr_ubxd_alt (lit, expr)
717 = hang (hsep [ppr lit, ptext SLIT("->")])
718 4 ((<>) (ppr expr) semi)
722 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
724 = getPprStyle $ \ sty ->
725 if userStyle sty || isEmptyUniqSet lvs then
728 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
732 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
733 => GenStgRhs bndr bdee -> SDoc
736 pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
740 brackets (ifPprDebug (ppr free_var)),
741 ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
744 pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
745 = hang (hcat [ppr cc,
748 brackets (ifPprDebug (interppSP free_vars)),
749 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
752 pprStgRhs (StgRhsCon cc con args)
754 space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
756 pprMaybeSRT (NoSRT) = empty
757 pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
761 pp_binder_info NoStgBinderInfo = empty
763 -- cases so boring that we print nothing
764 pp_binder_info (StgBinderInfo True b c d e) = empty
767 pp_binder_info (StgBinderInfo a b c d e)
768 = getPprStyle $ \ sty ->
769 if userStyle sty then
772 parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
775 Collect @IdInfo@ stuff that is most easily just snaffled straight
776 from the STG bindings.
779 stgArity :: StgRhs -> Int
781 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
782 stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args