2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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.
12 #include "HsVersions.h"
16 SYN_IE(GenStgLiveVars),
18 GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
19 GenStgCaseAlts(..), GenStgCaseDefault(..),
24 stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc,
25 stgNormalOcc, stgFakeFunAppOcc,
28 -- a set of synonyms for the most common (only :-) parameterisation
29 SYN_IE(StgArg), SYN_IE(StgLiveVars),
30 SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs),
31 SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault),
37 collectFinalStgBinders
42 import CostCentre ( showCostCentre, CostCentre )
43 import Id ( idPrimRep, SYN_IE(DataCon),
44 GenId{-instance NamedThing-}, SYN_IE(Id) )
45 import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
46 import Outputable ( PprStyle(..), userStyle,
47 ifPprDebug, interppSP, interpp'SP,
48 Outputable(..){-instance * Bool-}
50 import PprType ( GenType{-instance Outputable-} )
51 import Pretty -- all of it
52 import PrimOp ( PrimOp{-instance Outputable-} )
53 import Type ( SYN_IE(Type) )
54 import Unique ( pprUnique, Unique )
55 import UniqSet ( isEmptyUniqSet, uniqSetToList, SYN_IE(UniqSet) )
59 %************************************************************************
61 \subsection{@GenStgBinding@}
63 %************************************************************************
65 As usual, expressions are interesting; other things are boring. Here
66 are the boring things [except note the @GenStgRhs@], parameterised
67 with respect to binder and occurrence information (just as in
71 data GenStgBinding bndr occ
72 = StgNonRec bndr (GenStgRhs bndr occ)
73 | StgRec [(bndr, GenStgRhs bndr occ)]
74 | StgCoerceBinding bndr occ -- UNUSED?
77 %************************************************************************
79 \subsection{@GenStgArg@}
81 %************************************************************************
87 | StgConArg DataCon -- A nullary data constructor
91 getArgPrimRep (StgVarArg local) = idPrimRep local
92 getArgPrimRep (StgConArg con) = idPrimRep con
93 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
95 isLitLitArg (StgLitArg x) = isLitLitLit x
99 %************************************************************************
101 \subsection{STG expressions}
103 %************************************************************************
105 The @GenStgExpr@ data type is parameterised on binder and occurrence
108 %************************************************************************
110 \subsubsection{@GenStgExpr@ application}
112 %************************************************************************
114 An application is of a function to a list of atoms [not expressions].
115 Operationally, we want to push the arguments on the stack and call the
116 function. (If the arguments were expressions, we would have to build
117 their closures first.)
119 There is no constructor for a lone variable; it would appear as
122 type GenStgLiveVars occ = UniqSet occ
124 data GenStgExpr bndr occ
126 (GenStgArg occ) -- function
127 [GenStgArg occ] -- arguments
128 (GenStgLiveVars occ) -- Live vars in continuation; ie not
129 -- including the function and args
131 -- NB: a literal is: StgApp <lit-atom> [] ...
134 %************************************************************************
136 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
138 %************************************************************************
140 There are two specialised forms of application, for
141 constructors and primitives.
143 | StgCon -- always saturated
144 Id -- data constructor
146 (GenStgLiveVars occ) -- Live vars in continuation; ie not
147 -- including the constr and args
149 | StgPrim -- always saturated
152 (GenStgLiveVars occ) -- Live vars in continuation; ie not
153 -- including the op and args
155 These forms are to do ``inline versions,'' as it were.
156 An example might be: @f x = x:[]@.
158 %************************************************************************
160 \subsubsection{@GenStgExpr@: case-expressions}
162 %************************************************************************
164 This has the same boxed/unboxed business as Core case expressions.
167 (GenStgExpr bndr occ)
168 -- the thing to examine
170 (GenStgLiveVars occ) -- Live vars of whole case
171 -- expression; i.e., those which mustn't be
174 (GenStgLiveVars occ) -- Live vars of RHSs;
175 -- i.e., those which must be saved before eval.
177 -- note that an alt's constructor's
178 -- binder-variables are NOT counted in the
179 -- free vars for the alt's RHS
181 Unique -- Occasionally needed to compile case
182 -- statements, as the uniq for a local
183 -- variable to hold the tag of a primop with
186 (GenStgCaseAlts bndr occ)
189 %************************************************************************
191 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
193 %************************************************************************
195 The various forms of let(rec)-expression encode most of the
196 interesting things we want to do.
200 let-closure x = [free-vars] expr [args]
205 let x = (\free-vars -> \args -> expr) free-vars
207 \tr{args} may be empty (and is for most closures). It isn't under
208 circumstances like this:
214 let-closure x = [z] [y] (y+z)
216 The idea is that we compile code for @(y+z)@ in an environment in which
217 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
218 offset from the stack pointer.
220 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
224 let-constructor x = Constructor [args]
228 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
231 Letrec-expressions are essentially the same deal as
232 let-closure/let-constructor, so we use a common structure and
233 distinguish between them with an @is_recursive@ boolean flag.
237 let-unboxed u = an arbitrary arithmetic expression in unboxed values
240 All the stuff on the RHS must be fully evaluated. No function calls either!
242 (We've backed away from this toward case-expressions with
243 suitably-magical alts ...)
246 ~[Advanced stuff here! Not to start with, but makes pattern matching
247 generate more efficient code.]
250 let-escapes-not fail = expr
253 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
254 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
255 Rather than build a closure for @fail@, all we need do is to record the stack
256 level at the moment of the @let-escapes-not@; then entering @fail@ is just
257 a matter of adjusting the stack pointer back down to that point and entering
262 f x y = let z = huge-expression in
268 (A let-escapes-not is an @StgLetNoEscape@.)
271 We may eventually want:
273 let-literal x = Literal
277 (ToDo: is this obsolete?)
280 And so the code for let(rec)-things:
283 (GenStgBinding bndr occ) -- right hand sides (see below)
284 (GenStgExpr bndr occ) -- body
286 | StgLetNoEscape -- remember: ``advanced stuff''
287 (GenStgLiveVars occ) -- Live in the whole let-expression
288 -- Mustn't overwrite these stack slots
289 -- *Doesn't* include binders of the let(rec).
291 (GenStgLiveVars occ) -- Live in the right hand sides (only)
292 -- These are the ones which must be saved on
293 -- the stack if they aren't there already
294 -- *Does* include binders of the let(rec) if recursive.
296 (GenStgBinding bndr occ) -- right hand sides (see below)
297 (GenStgExpr bndr occ) -- body
300 %************************************************************************
302 \subsubsection{@GenStgExpr@: @scc@ expressions}
304 %************************************************************************
306 Finally for @scc@ expressions we introduce a new STG construct.
310 Type -- the type of the body
311 CostCentre -- label of SCC expression
312 (GenStgExpr bndr occ) -- scc expression
316 %************************************************************************
318 \subsection{STG right-hand sides}
320 %************************************************************************
322 Here's the rest of the interesting stuff for @StgLet@s; the first
323 flavour is for closures:
325 data GenStgRhs bndr occ
327 CostCentre -- cost centre to be attached (default is CCC)
328 StgBinderInfo -- Info about how this binder is used (see below)
329 [occ] -- non-global free vars; a list, rather than
330 -- a set, because order is important
331 UpdateFlag -- ReEntrant | Updatable | SingleEntry
332 [bndr] -- arguments; if empty, then not a function;
333 -- as above, order is important
334 (GenStgExpr bndr occ) -- body
336 An example may be in order. Consider:
338 let t = \x -> \y -> ... x ... y ... p ... q in e
340 Pulling out the free vars and stylising somewhat, we get the equivalent:
342 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
344 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
345 offsets from @Node@ into the closure, and the code ptr for the closure
346 will be exactly that in parentheses above.
348 The second flavour of right-hand-side is for constructors (simple but important):
351 CostCentre -- Cost centre to be attached (default is CCC).
352 -- Top-level (static) ones will end up with
353 -- DontCareCC, because we don't count static
354 -- data in heap profiles, and we don't set CCC
355 -- from static closure.
357 [GenStgArg occ] -- args
360 Here's the @StgBinderInfo@ type, and its combining op:
365 Bool -- At least one occurrence as an argument
367 Bool -- At least one occurrence in an unsaturated application
369 Bool -- This thing (f) has at least occurrence of the form:
370 -- x = [..] \u [] -> f a b c
371 -- where the application is saturated
373 Bool -- Ditto for non-updatable x.
375 Bool -- At least one fake application occurrence, that is
376 -- an StgApp f args where args is an empty list
377 -- This is due to the fact that we do not have a
378 -- StgVar constructor.
379 -- Used by the lambda lifter.
380 -- True => "at least one unsat app" is True too
382 stgArgOcc = StgBinderInfo True False False False False
383 stgUnsatOcc = StgBinderInfo False True False False False
384 stgStdHeapOcc = StgBinderInfo False False True False False
385 stgNoUpdHeapOcc = StgBinderInfo False False False True False
386 stgNormalOcc = StgBinderInfo False False False False False
387 -- [Andre] can't think of a good name for the last one.
388 stgFakeFunAppOcc = StgBinderInfo False True False False True
390 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
392 combineStgBinderInfo NoStgBinderInfo info2 = info2
393 combineStgBinderInfo info1 NoStgBinderInfo = info1
394 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
395 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
396 = StgBinderInfo (arg1 || arg2)
398 (std_heap1 || std_heap2)
399 (upd_heap1 || upd_heap2)
403 %************************************************************************
405 \subsection[Stg-case-alternatives]{STG case alternatives}
407 %************************************************************************
409 Just like in @CoreSyntax@ (except no type-world stuff).
412 data GenStgCaseAlts bndr occ
413 = StgAlgAlts Type -- so we can find out things about constructor family
414 [(Id, -- alts: data constructor,
415 [bndr], -- constructor's parameters,
416 [Bool], -- "use mask", same length as
417 -- parameters; a True in a
418 -- param's position if it is
420 GenStgExpr bndr occ)] -- ...right-hand side.
421 (GenStgCaseDefault bndr occ)
422 | StgPrimAlts Type -- so we can find out things about constructor family
423 [(Literal, -- alts: unboxed literal,
424 GenStgExpr bndr occ)] -- rhs.
425 (GenStgCaseDefault bndr occ)
427 data GenStgCaseDefault bndr occ
428 = StgNoDefault -- small con family: all
429 -- constructor accounted for
430 | StgBindDefault bndr -- form: var -> expr
431 Bool -- True <=> var is used in rhs
432 -- i.e., False <=> "_ -> expr"
433 (GenStgExpr bndr occ)
436 %************************************************************************
438 \subsection[Stg]{The Plain STG parameterisation}
440 %************************************************************************
442 This happens to be the only one we use at the moment.
445 type StgBinding = GenStgBinding Id Id
446 type StgArg = GenStgArg Id
447 type StgLiveVars = GenStgLiveVars Id
448 type StgExpr = GenStgExpr Id Id
449 type StgRhs = GenStgRhs Id Id
450 type StgCaseAlts = GenStgCaseAlts Id Id
451 type StgCaseDefault = GenStgCaseDefault Id Id
454 %************************************************************************
456 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
458 %************************************************************************
460 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
463 data UpdateFlag = ReEntrant | Updatable | SingleEntry
465 instance Outputable UpdateFlag where
467 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
470 %************************************************************************
472 \subsection[Stg-utility-functions]{Utility functions}
474 %************************************************************************
477 For doing interfaces, we want the exported top-level Ids from the
478 final pre-codegen STG code, so as to be sure we have the
479 latest/greatest pragma info.
482 collectFinalStgBinders
483 :: [StgBinding] -- input program
486 collectFinalStgBinders [] = []
487 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
488 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
491 %************************************************************************
493 \subsection[Stg-pretty-printing]{Pretty-printing}
495 %************************************************************************
497 Robin Popplestone asked for semi-colon separators on STG binds; here's
498 hoping he likes terminators instead... Ditto for case alternatives.
501 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
502 PprStyle -> GenStgBinding bndr bdee -> Doc
504 pprStgBinding sty (StgNonRec bndr rhs)
505 = hang (hsep [ppr sty bndr, equals])
506 4 ((<>) (ppr sty rhs) semi)
508 pprStgBinding sty (StgCoerceBinding bndr occ)
509 = hang (hsep [ppr sty bndr, equals, ptext SLIT("{-Coerce-}")])
510 4 ((<>) (ppr sty occ) semi)
512 pprStgBinding sty (StgRec pairs)
513 = vcat ((ifPprDebug sty (ptext SLIT("{- StgRec (begin) -}"))) :
514 (map (ppr_bind sty) pairs) ++ [(ifPprDebug sty (ptext SLIT("{- StgRec (end) -}")))])
516 ppr_bind sty (bndr, expr)
517 = hang (hsep [ppr sty bndr, equals])
518 4 ((<>) (ppr sty expr) semi)
520 pprPlainStgBinding :: PprStyle -> StgBinding -> Doc
521 pprPlainStgBinding sty b = pprStgBinding sty b
525 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
528 instance (Outputable bndr, Outputable bdee, Ord bdee)
529 => Outputable (GenStgBinding bndr bdee) where
532 instance (Outputable bndr, Outputable bdee, Ord bdee)
533 => Outputable (GenStgExpr bndr bdee) where
536 instance (Outputable bndr, Outputable bdee, Ord bdee)
537 => Outputable (GenStgRhs bndr bdee) where
538 ppr sty rhs = pprStgRhs sty rhs
542 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Doc
544 pprStgArg sty (StgVarArg var) = ppr sty var
545 pprStgArg sty (StgConArg con) = ppr sty con
546 pprStgArg sty (StgLitArg lit) = ppr sty lit
550 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
551 PprStyle -> GenStgExpr bndr bdee -> Doc
553 pprStgExpr sty (StgApp func [] lvs)
554 = (<>) (ppr sty func) (pprStgLVs sty lvs)
557 pprStgExpr sty (StgApp func args lvs)
558 = hang ((<>) (ppr sty func) (pprStgLVs sty lvs))
559 4 (sep (map (ppr sty) args))
563 pprStgExpr sty (StgCon con args lvs)
564 = hcat [ (<>) (ppr sty con) (pprStgLVs sty lvs),
565 ptext SLIT("! ["), interppSP sty args, char ']' ]
567 pprStgExpr sty (StgPrim op args lvs)
568 = hcat [ ppr sty op, char '#', pprStgLVs sty lvs,
569 ptext SLIT(" ["), interppSP sty args, char ']' ]
573 -- special case: let v = <very specific thing>
579 -- Very special! Suspicious! (SLPJ)
581 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
584 (hang (hcat [ptext SLIT("let { "), ppr sty bndr, ptext SLIT(" = "),
585 text (showCostCentre sty True{-as string-} cc),
586 pp_binder_info sty bi,
587 ptext SLIT(" ["), ifPprDebug sty (interppSP sty free_vars), ptext SLIT("] \\"),
588 ppr sty upd_flag, ptext SLIT(" ["),
589 interppSP sty args, char ']'])
590 8 (sep [hsep [ppr sty rhs, ptext SLIT("} in")]]))
593 -- special case: let ... in let ...
595 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
597 (sep [hang (ptext SLIT("let {")) 2 (hsep [pprStgBinding sty bind, ptext SLIT("} in")])])
601 pprStgExpr sty (StgLet bind expr)
602 = sep [hang (ptext SLIT("let {")) 2 (pprStgBinding sty bind),
603 hang (ptext SLIT("} in ")) 2 (ppr sty expr)]
605 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
606 = sep [hang (ptext SLIT("let-no-escape {"))
607 2 (pprStgBinding sty bind),
608 hang ((<>) (ptext SLIT("} in "))
611 hcat [ptext SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole),
612 ptext SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss),
618 pprStgExpr sty (StgSCC ty cc expr)
619 = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre sty True{-as string-} cc)],
620 pprStgExpr sty expr ]
624 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
625 = sep [sep [ptext SLIT("case"),
626 nest 4 (hsep [pprStgExpr sty expr,
627 ifPprDebug sty ((<>) (ptext SLIT("::")) (pp_ty alts))]),
631 hcat [ptext SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole),
632 ptext SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss),
633 ptext SLIT("]; uniq: "), pprUnique uniq])),
634 nest 2 (ppr_alts sty alts),
637 ppr_default sty StgNoDefault = empty
638 ppr_default sty (StgBindDefault bndr used expr)
639 = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr sty expr)
641 pp_binder = if used then ppr sty bndr else char '_'
643 pp_ty (StgAlgAlts ty _ _) = ppr sty ty
644 pp_ty (StgPrimAlts ty _ _) = ppr sty ty
646 ppr_alts sty (StgAlgAlts ty alts deflt)
647 = vcat [ vcat (map (ppr_bxd_alt sty) alts),
648 ppr_default sty deflt ]
650 ppr_bxd_alt sty (con, params, use_mask, expr)
651 = hang (hsep [ppr sty con, interppSP sty params, ptext SLIT("->")])
652 4 ((<>) (ppr sty expr) semi)
654 ppr_alts sty (StgPrimAlts ty alts deflt)
655 = vcat [ vcat (map (ppr_ubxd_alt sty) alts),
656 ppr_default sty deflt ]
658 ppr_ubxd_alt sty (lit, expr)
659 = hang (hsep [ppr sty lit, ptext SLIT("->")])
660 4 ((<>) (ppr sty expr) semi)
664 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Doc
666 pprStgLVs sty lvs | userStyle sty = empty
669 = if isEmptyUniqSet lvs then
672 hcat [text "{-lvs:", interpp'SP sty (uniqSetToList lvs), text "-}"]
676 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
677 PprStyle -> GenStgRhs bndr bdee -> Doc
680 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
681 = hcat [ text (showCostCentre sty True{-as String-} cc),
682 pp_binder_info sty bi,
683 ptext SLIT(" ["), ifPprDebug sty (ppr sty free_var),
684 ptext SLIT("] \\"), ppr sty upd_flag, ptext SLIT(" [] "), ppr sty func ]
686 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
687 = hang (hcat [ text (showCostCentre sty True{-as String-} cc),
688 pp_binder_info sty bi,
689 ptext SLIT(" ["), ifPprDebug sty (interppSP sty free_vars),
690 ptext SLIT("] \\"), ppr sty upd_flag, ptext SLIT(" ["), interppSP sty args, char ']'])
693 pprStgRhs sty (StgRhsCon cc con args)
694 = hcat [ text (showCostCentre sty True{-as String-} cc),
695 space, ppr sty con, ptext SLIT("! ["), interppSP sty args, char ']' ]
698 pp_binder_info sty _ | userStyle sty = empty
700 pp_binder_info sty NoStgBinderInfo = empty
702 -- cases so boring that we print nothing
703 pp_binder_info sty (StgBinderInfo True b c d e) = empty
706 pp_binder_info sty (StgBinderInfo a b c d e)
707 = parens (hsep (punctuate comma (map pp_bool [a,b,c,d,e])))
709 pp_bool x = ppr (panic "pp_bool") x
712 Collect @IdInfo@ stuff that is most easily just snaffled straight
713 from the STG bindings.
716 stgArity :: StgRhs -> Int
718 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
719 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args