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, 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 isDllArg :: StgArg -> Bool
101 -- Does this argument refer to something in a different DLL?
102 isDllArg (StgVarArg v) = isDllName (idName v)
103 isDllArg (StgLitArg lit) = isLitLitLit lit
105 isDllConApp :: DataCon -> [StgArg] -> Bool
106 -- Does this constructor application refer to
107 -- anything in a different DLL?
108 -- If so, we can't allocate it statically
109 isDllConApp con args = isDllName (dataConName con) || any isDllArg args
111 stgArgType :: StgArg -> Type
112 -- Very half baked becase we have lost the type arguments
113 stgArgType (StgVarArg v) = idType v
114 stgArgType (StgLitArg lit) = literalType lit
117 %************************************************************************
119 \subsection{STG expressions}
121 %************************************************************************
123 The @GenStgExpr@ data type is parameterised on binder and occurrence
126 %************************************************************************
128 \subsubsection{@GenStgExpr@ application}
130 %************************************************************************
132 An application is of a function to a list of atoms [not expressions].
133 Operationally, we want to push the arguments on the stack and call the
134 function. (If the arguments were expressions, we would have to build
135 their closures first.)
137 There is no constructor for a lone variable; it would appear as
140 type GenStgLiveVars occ = UniqSet occ
142 data GenStgExpr bndr occ
145 [GenStgArg occ] -- arguments; may be empty
148 %************************************************************************
150 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
152 %************************************************************************
154 There are a specialised forms of application, for
155 constructors, primitives, and literals.
160 [GenStgArg occ] -- Saturated
163 [GenStgArg occ] -- Saturated
164 Type -- Result type; we need to know the result type
165 -- so that we can assign result registers.
168 %************************************************************************
170 \subsubsection{@StgLam@}
172 %************************************************************************
174 StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished
175 it encodes (\x -> e) as (let f = \x -> e in f)
179 Type -- Type of whole lambda (useful when making a binder for it)
181 StgExpr -- Body of lambda
185 %************************************************************************
187 \subsubsection{@GenStgExpr@: case-expressions}
189 %************************************************************************
191 This has the same boxed/unboxed business as Core case expressions.
194 (GenStgExpr bndr occ)
195 -- the thing to examine
197 (GenStgLiveVars occ) -- Live vars of whole case
198 -- expression; i.e., those which mustn't be
201 (GenStgLiveVars occ) -- Live vars of RHSs;
202 -- i.e., those which must be saved before eval.
204 -- note that an alt's constructor's
205 -- binder-variables are NOT counted in the
206 -- free vars for the alt's RHS
208 bndr -- binds the result of evaluating the scrutinee
210 SRT -- The SRT for the continuation
212 (GenStgCaseAlts bndr occ)
215 %************************************************************************
217 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
219 %************************************************************************
221 The various forms of let(rec)-expression encode most of the
222 interesting things we want to do.
226 let-closure x = [free-vars] expr [args]
231 let x = (\free-vars -> \args -> expr) free-vars
233 \tr{args} may be empty (and is for most closures). It isn't under
234 circumstances like this:
240 let-closure x = [z] [y] (y+z)
242 The idea is that we compile code for @(y+z)@ in an environment in which
243 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
244 offset from the stack pointer.
246 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
250 let-constructor x = Constructor [args]
254 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
257 Letrec-expressions are essentially the same deal as
258 let-closure/let-constructor, so we use a common structure and
259 distinguish between them with an @is_recursive@ boolean flag.
263 let-unboxed u = an arbitrary arithmetic expression in unboxed values
266 All the stuff on the RHS must be fully evaluated. No function calls either!
268 (We've backed away from this toward case-expressions with
269 suitably-magical alts ...)
272 ~[Advanced stuff here! Not to start with, but makes pattern matching
273 generate more efficient code.]
276 let-escapes-not fail = expr
279 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
280 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
281 Rather than build a closure for @fail@, all we need do is to record the stack
282 level at the moment of the @let-escapes-not@; then entering @fail@ is just
283 a matter of adjusting the stack pointer back down to that point and entering
288 f x y = let z = huge-expression in
294 (A let-escapes-not is an @StgLetNoEscape@.)
297 We may eventually want:
299 let-literal x = Literal
303 (ToDo: is this obsolete?)
306 And so the code for let(rec)-things:
309 (GenStgBinding bndr occ) -- right hand sides (see below)
310 (GenStgExpr bndr occ) -- body
312 | StgLetNoEscape -- remember: ``advanced stuff''
313 (GenStgLiveVars occ) -- Live in the whole let-expression
314 -- Mustn't overwrite these stack slots
315 -- *Doesn't* include binders of the let(rec).
317 (GenStgLiveVars occ) -- Live in the right hand sides (only)
318 -- These are the ones which must be saved on
319 -- the stack if they aren't there already
320 -- *Does* include binders of the let(rec) if recursive.
322 (GenStgBinding bndr occ) -- right hand sides (see below)
323 (GenStgExpr bndr occ) -- body
326 %************************************************************************
328 \subsubsection{@GenStgExpr@: @scc@ expressions}
330 %************************************************************************
332 Finally for @scc@ expressions we introduce a new STG construct.
336 CostCentre -- label of SCC expression
337 (GenStgExpr bndr occ) -- scc expression
341 %************************************************************************
343 \subsection{STG right-hand sides}
345 %************************************************************************
347 Here's the rest of the interesting stuff for @StgLet@s; the first
348 flavour is for closures:
350 data GenStgRhs bndr occ
352 CostCentreStack -- CCS to be attached (default is CurrentCCS)
353 StgBinderInfo -- Info about how this binder is used (see below)
354 SRT -- The closures's SRT
355 [occ] -- non-global free vars; a list, rather than
356 -- a set, because order is important
357 UpdateFlag -- ReEntrant | Updatable | SingleEntry
358 [bndr] -- arguments; if empty, then not a function;
359 -- as above, order is important.
360 (GenStgExpr bndr occ) -- body
362 An example may be in order. Consider:
364 let t = \x -> \y -> ... x ... y ... p ... q in e
366 Pulling out the free vars and stylising somewhat, we get the equivalent:
368 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
370 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
371 offsets from @Node@ into the closure, and the code ptr for the closure
372 will be exactly that in parentheses above.
374 The second flavour of right-hand-side is for constructors (simple but important):
377 CostCentreStack -- CCS to be attached (default is CurrentCCS).
378 -- Top-level (static) ones will end up with
379 -- DontCareCCS, because we don't count static
380 -- data in heap profiles, and we don't set CCCS
381 -- from static closure.
382 DataCon -- constructor
383 [GenStgArg occ] -- args
386 Here's the @StgBinderInfo@ type, and its combining op:
391 Bool -- At least one occurrence as an argument
393 Bool -- At least one occurrence in an unsaturated application
395 Bool -- This thing (f) has at least occurrence of the form:
396 -- x = [..] \u [] -> f a b c
397 -- where the application is saturated
399 Bool -- Ditto for non-updatable x.
401 Bool -- At least one fake application occurrence, that is
402 -- an StgApp f args where args is an empty list
403 -- This is due to the fact that we do not have a
404 -- StgVar constructor.
405 -- Used by the lambda lifter.
406 -- True => "at least one unsat app" is True too
408 stgArgOcc = StgBinderInfo True False False False False
409 stgUnsatOcc = StgBinderInfo False True False False False
410 stgStdHeapOcc = StgBinderInfo False False True False False
411 stgNoUpdHeapOcc = StgBinderInfo False False False True False
412 stgNormalOcc = StgBinderInfo False False False False False
413 -- [Andre] can't think of a good name for the last one.
414 stgFakeFunAppOcc = StgBinderInfo False True False False True
416 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
418 combineStgBinderInfo NoStgBinderInfo info2 = info2
419 combineStgBinderInfo info1 NoStgBinderInfo = info1
420 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
421 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
422 = StgBinderInfo (arg1 || arg2)
424 (std_heap1 || std_heap2)
425 (upd_heap1 || upd_heap2)
429 %************************************************************************
431 \subsection[Stg-case-alternatives]{STG case alternatives}
433 %************************************************************************
435 Just like in @CoreSyntax@ (except no type-world stuff).
438 data GenStgCaseAlts bndr occ
439 = StgAlgAlts Type -- so we can find out things about constructor family
440 [(DataCon, -- alts: data constructor,
441 [bndr], -- constructor's parameters,
442 [Bool], -- "use mask", same length as
443 -- parameters; a True in a
444 -- param's position if it is
446 GenStgExpr bndr occ)] -- ...right-hand side.
447 (GenStgCaseDefault bndr occ)
448 | StgPrimAlts Type -- so we can find out things about constructor family
449 [(Literal, -- alts: unboxed literal,
450 GenStgExpr bndr occ)] -- rhs.
451 (GenStgCaseDefault bndr occ)
453 data GenStgCaseDefault bndr occ
454 = StgNoDefault -- small con family: all
455 -- constructor accounted for
456 | StgBindDefault (GenStgExpr bndr occ)
459 %************************************************************************
461 \subsection[Stg]{The Plain STG parameterisation}
463 %************************************************************************
465 This happens to be the only one we use at the moment.
468 type StgBinding = GenStgBinding Id Id
469 type StgArg = GenStgArg Id
470 type StgLiveVars = GenStgLiveVars Id
471 type StgExpr = GenStgExpr Id Id
472 type StgRhs = GenStgRhs Id Id
473 type StgCaseAlts = GenStgCaseAlts Id Id
474 type StgCaseDefault = GenStgCaseDefault Id Id
477 %************************************************************************
479 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
481 %************************************************************************
483 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
485 A @ReEntrant@ closure may be entered multiple times, but should not be
486 updated or blackholed. An @Updatable@ closure should be updated after
487 evaluation (and may be blackholed during evaluation). A @SingleEntry@
488 closure will only be entered once, and so need not be updated but may
489 safely be blackholed.
492 data UpdateFlag = ReEntrant | Updatable | SingleEntry
494 instance Outputable UpdateFlag where
496 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
498 isUpdatable ReEntrant = False
499 isUpdatable SingleEntry = False
500 isUpdatable Updatable = True
503 %************************************************************************
505 \subsubsection[Static Reference Tables]{@SRT@}
507 %************************************************************************
509 There is one SRT per top-level function group. Each local binding and
510 case expression within this binding group has a subrange of the whole
511 SRT, expressed as an offset and length.
515 | SRT !Int{-offset-} !Int{-length-}
520 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
521 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
524 %************************************************************************
526 \subsection[Stg-utility-functions]{Utility functions}
528 %************************************************************************
531 For doing interfaces, we want the exported top-level Ids from the
532 final pre-codegen STG code, so as to be sure we have the
533 latest/greatest pragma info.
536 collectFinalStgBinders
537 :: [StgBinding] -- input program
540 collectFinalStgBinders [] = []
541 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
542 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
545 %************************************************************************
547 \subsection[Stg-pretty-printing]{Pretty-printing}
549 %************************************************************************
551 Robin Popplestone asked for semi-colon separators on STG binds; here's
552 hoping he likes terminators instead... Ditto for case alternatives.
555 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
556 => GenStgBinding bndr bdee -> SDoc
558 pprGenStgBinding (StgNonRec bndr rhs)
559 = hang (hsep [ppr bndr, equals])
560 4 ((<>) (ppr rhs) semi)
562 pprGenStgBinding (StgRec pairs)
563 = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
564 (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
566 ppr_bind (bndr, expr)
567 = hang (hsep [ppr bndr, equals])
568 4 ((<>) (ppr expr) semi)
570 pprStgBinding :: StgBinding -> SDoc
571 pprStgBinding bind = pprGenStgBinding bind
573 pprStgBindings :: [StgBinding] -> SDoc
574 pprStgBindings binds = vcat (map pprGenStgBinding binds)
576 pprGenStgBindingWithSRT
577 :: (Outputable bndr, Outputable bdee, Ord bdee)
578 => (GenStgBinding bndr bdee,[Id]) -> SDoc
580 pprGenStgBindingWithSRT (bind,srt)
581 = vcat [ pprGenStgBinding bind,
582 ptext SLIT("SRT: ") <> ppr srt ]
584 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
585 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
589 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
592 instance (Outputable bndr, Outputable bdee, Ord bdee)
593 => Outputable (GenStgBinding bndr bdee) where
594 ppr = pprGenStgBinding
596 instance (Outputable bndr, Outputable bdee, Ord bdee)
597 => Outputable (GenStgExpr bndr bdee) where
600 instance (Outputable bndr, Outputable bdee, Ord bdee)
601 => Outputable (GenStgRhs bndr bdee) where
602 ppr rhs = pprStgRhs rhs
606 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
608 pprStgArg (StgVarArg var) = ppr var
609 pprStgArg (StgLitArg con) = ppr con
610 pprStgARg (StgTypeArg ty) = char '@' <+> ppr ty
614 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
615 => GenStgExpr bndr bdee -> SDoc
617 pprStgExpr (StgLit lit) = ppr lit
620 pprStgExpr (StgApp func args)
622 4 (sep (map (ppr) args))
626 pprStgExpr (StgConApp con args)
627 = hsep [ ppr con, brackets (interppSP args)]
629 pprStgExpr (StgPrimApp op args _)
630 = hsep [ ppr op, brackets (interppSP args)]
632 pprStgExpr (StgLam _ bndrs body)
633 =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
638 -- special case: let v = <very specific thing>
644 -- Very special! Suspicious! (SLPJ)
646 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
649 (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
652 ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
653 ppr upd_flag, ptext SLIT(" ["),
654 interppSP args, char ']'])
655 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
658 -- special case: let ... in let ...
660 pprStgExpr (StgLet bind expr@(StgLet _ _))
662 (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
666 pprStgExpr (StgLet bind expr)
667 = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
668 hang (ptext SLIT("} in ")) 2 (ppr expr)]
670 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
671 = sep [hang (ptext SLIT("let-no-escape {"))
672 2 (pprGenStgBinding bind),
673 hang ((<>) (ptext SLIT("} in "))
676 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
677 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
683 pprStgExpr (StgSCC cc expr)
684 = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
689 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
690 = sep [sep [ptext SLIT("case"),
691 nest 4 (hsep [pprStgExpr expr,
692 ifPprDebug (dcolon <+> pp_ty alts)]),
693 ptext SLIT("of"), ppr bndr, char '{'],
696 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
697 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
700 nest 2 (ppr_alts alts),
703 ppr_default StgNoDefault = empty
704 ppr_default (StgBindDefault expr)
705 = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
707 pp_ty (StgAlgAlts ty _ _) = ppr ty
708 pp_ty (StgPrimAlts ty _ _) = ppr ty
710 ppr_alts (StgAlgAlts ty alts deflt)
711 = vcat [ vcat (map (ppr_bxd_alt) alts),
714 ppr_bxd_alt (con, params, use_mask, expr)
715 = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
716 4 ((<>) (ppr expr) semi)
718 ppr_alts (StgPrimAlts ty alts deflt)
719 = vcat [ vcat (map (ppr_ubxd_alt) alts),
722 ppr_ubxd_alt (lit, expr)
723 = hang (hsep [ppr lit, ptext SLIT("->")])
724 4 ((<>) (ppr expr) semi)
728 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
730 = getPprStyle $ \ sty ->
731 if userStyle sty || isEmptyUniqSet lvs then
734 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
738 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
739 => GenStgRhs bndr bdee -> SDoc
742 pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
746 brackets (ifPprDebug (ppr free_var)),
747 ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
750 pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
751 = hang (hcat [ppr cc,
754 brackets (ifPprDebug (interppSP free_vars)),
755 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
758 pprStgRhs (StgRhsCon cc con args)
760 space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
762 pprMaybeSRT (NoSRT) = empty
763 pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
767 pp_binder_info NoStgBinderInfo = empty
769 -- cases so boring that we print nothing
770 pp_binder_info (StgBinderInfo True b c d e) = empty
773 pp_binder_info (StgBinderInfo a b c d e)
774 = getPprStyle $ \ sty ->
775 if userStyle sty then
778 parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
781 Collect @IdInfo@ stuff that is most easily just snaffled straight
782 from the STG bindings.
785 stgArity :: StgRhs -> Int
787 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
788 stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args