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.
16 GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
17 GenStgCaseAlts(..), GenStgCaseDefault(..),
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,
31 pprStgBinding, pprStgBindings,
35 collectFinalStgBinders
38 #include "HsVersions.h"
40 import CostCentre ( showCostCentre, CostCentre )
41 import Id ( idPrimRep, DataCon,
42 GenId{-instance NamedThing-}, Id )
43 import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
45 import PrimOp ( PrimOp{-instance Outputable-} )
47 import Unique ( pprUnique, Unique )
48 import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
52 %************************************************************************
54 \subsection{@GenStgBinding@}
56 %************************************************************************
58 As usual, expressions are interesting; other things are boring. Here
59 are the boring things [except note the @GenStgRhs@], parameterised
60 with respect to binder and occurrence information (just as in
64 data GenStgBinding bndr occ
65 = StgNonRec bndr (GenStgRhs bndr occ)
66 | StgRec [(bndr, GenStgRhs bndr occ)]
67 | StgCoerceBinding bndr occ -- UNUSED?
70 %************************************************************************
72 \subsection{@GenStgArg@}
74 %************************************************************************
80 | StgConArg DataCon -- A nullary data constructor
84 getArgPrimRep (StgVarArg local) = idPrimRep local
85 getArgPrimRep (StgConArg con) = idPrimRep con
86 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
88 isLitLitArg (StgLitArg x) = isLitLitLit x
92 %************************************************************************
94 \subsection{STG expressions}
96 %************************************************************************
98 The @GenStgExpr@ data type is parameterised on binder and occurrence
101 %************************************************************************
103 \subsubsection{@GenStgExpr@ application}
105 %************************************************************************
107 An application is of a function to a list of atoms [not expressions].
108 Operationally, we want to push the arguments on the stack and call the
109 function. (If the arguments were expressions, we would have to build
110 their closures first.)
112 There is no constructor for a lone variable; it would appear as
115 type GenStgLiveVars occ = UniqSet occ
117 data GenStgExpr bndr occ
119 (GenStgArg occ) -- function
120 [GenStgArg occ] -- arguments
121 (GenStgLiveVars occ) -- Live vars in continuation; ie not
122 -- including the function and args
124 -- NB: a literal is: StgApp <lit-atom> [] ...
127 %************************************************************************
129 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
131 %************************************************************************
133 There are two specialised forms of application, for
134 constructors and primitives.
136 | StgCon -- always saturated
137 Id -- data constructor
139 (GenStgLiveVars occ) -- Live vars in continuation; ie not
140 -- including the constr and args
142 | StgPrim -- always saturated
145 (GenStgLiveVars occ) -- Live vars in continuation; ie not
146 -- including the op and args
148 These forms are to do ``inline versions,'' as it were.
149 An example might be: @f x = x:[]@.
151 %************************************************************************
153 \subsubsection{@GenStgExpr@: case-expressions}
155 %************************************************************************
157 This has the same boxed/unboxed business as Core case expressions.
160 (GenStgExpr bndr occ)
161 -- the thing to examine
163 (GenStgLiveVars occ) -- Live vars of whole case
164 -- expression; i.e., those which mustn't be
167 (GenStgLiveVars occ) -- Live vars of RHSs;
168 -- i.e., those which must be saved before eval.
170 -- note that an alt's constructor's
171 -- binder-variables are NOT counted in the
172 -- free vars for the alt's RHS
174 Unique -- Occasionally needed to compile case
175 -- statements, as the uniq for a local
176 -- variable to hold the tag of a primop with
179 (GenStgCaseAlts bndr occ)
182 %************************************************************************
184 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
186 %************************************************************************
188 The various forms of let(rec)-expression encode most of the
189 interesting things we want to do.
193 let-closure x = [free-vars] expr [args]
198 let x = (\free-vars -> \args -> expr) free-vars
200 \tr{args} may be empty (and is for most closures). It isn't under
201 circumstances like this:
207 let-closure x = [z] [y] (y+z)
209 The idea is that we compile code for @(y+z)@ in an environment in which
210 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
211 offset from the stack pointer.
213 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
217 let-constructor x = Constructor [args]
221 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
224 Letrec-expressions are essentially the same deal as
225 let-closure/let-constructor, so we use a common structure and
226 distinguish between them with an @is_recursive@ boolean flag.
230 let-unboxed u = an arbitrary arithmetic expression in unboxed values
233 All the stuff on the RHS must be fully evaluated. No function calls either!
235 (We've backed away from this toward case-expressions with
236 suitably-magical alts ...)
239 ~[Advanced stuff here! Not to start with, but makes pattern matching
240 generate more efficient code.]
243 let-escapes-not fail = expr
246 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
247 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
248 Rather than build a closure for @fail@, all we need do is to record the stack
249 level at the moment of the @let-escapes-not@; then entering @fail@ is just
250 a matter of adjusting the stack pointer back down to that point and entering
255 f x y = let z = huge-expression in
261 (A let-escapes-not is an @StgLetNoEscape@.)
264 We may eventually want:
266 let-literal x = Literal
270 (ToDo: is this obsolete?)
273 And so the code for let(rec)-things:
276 (GenStgBinding bndr occ) -- right hand sides (see below)
277 (GenStgExpr bndr occ) -- body
279 | StgLetNoEscape -- remember: ``advanced stuff''
280 (GenStgLiveVars occ) -- Live in the whole let-expression
281 -- Mustn't overwrite these stack slots
282 -- *Doesn't* include binders of the let(rec).
284 (GenStgLiveVars occ) -- Live in the right hand sides (only)
285 -- These are the ones which must be saved on
286 -- the stack if they aren't there already
287 -- *Does* include binders of the let(rec) if recursive.
289 (GenStgBinding bndr occ) -- right hand sides (see below)
290 (GenStgExpr bndr occ) -- body
293 %************************************************************************
295 \subsubsection{@GenStgExpr@: @scc@ expressions}
297 %************************************************************************
299 Finally for @scc@ expressions we introduce a new STG construct.
303 Type -- the type of the body
304 CostCentre -- label of SCC expression
305 (GenStgExpr bndr occ) -- scc expression
309 %************************************************************************
311 \subsection{STG right-hand sides}
313 %************************************************************************
315 Here's the rest of the interesting stuff for @StgLet@s; the first
316 flavour is for closures:
318 data GenStgRhs bndr occ
320 CostCentre -- cost centre to be attached (default is CCC)
321 StgBinderInfo -- Info about how this binder is used (see below)
322 [occ] -- non-global free vars; a list, rather than
323 -- a set, because order is important
324 UpdateFlag -- ReEntrant | Updatable | SingleEntry
325 [bndr] -- arguments; if empty, then not a function;
326 -- as above, order is important
327 (GenStgExpr bndr occ) -- body
329 An example may be in order. Consider:
331 let t = \x -> \y -> ... x ... y ... p ... q in e
333 Pulling out the free vars and stylising somewhat, we get the equivalent:
335 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
337 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
338 offsets from @Node@ into the closure, and the code ptr for the closure
339 will be exactly that in parentheses above.
341 The second flavour of right-hand-side is for constructors (simple but important):
344 CostCentre -- Cost centre to be attached (default is CCC).
345 -- Top-level (static) ones will end up with
346 -- DontCareCC, because we don't count static
347 -- data in heap profiles, and we don't set CCC
348 -- from static closure.
350 [GenStgArg occ] -- args
353 Here's the @StgBinderInfo@ type, and its combining op:
358 Bool -- At least one occurrence as an argument
360 Bool -- At least one occurrence in an unsaturated application
362 Bool -- This thing (f) has at least occurrence of the form:
363 -- x = [..] \u [] -> f a b c
364 -- where the application is saturated
366 Bool -- Ditto for non-updatable x.
368 Bool -- At least one fake application occurrence, that is
369 -- an StgApp f args where args is an empty list
370 -- This is due to the fact that we do not have a
371 -- StgVar constructor.
372 -- Used by the lambda lifter.
373 -- True => "at least one unsat app" is True too
375 stgArgOcc = StgBinderInfo True False False False False
376 stgUnsatOcc = StgBinderInfo False True False False False
377 stgStdHeapOcc = StgBinderInfo False False True False False
378 stgNoUpdHeapOcc = StgBinderInfo False False False True False
379 stgNormalOcc = StgBinderInfo False False False False False
380 -- [Andre] can't think of a good name for the last one.
381 stgFakeFunAppOcc = StgBinderInfo False True False False True
383 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
385 combineStgBinderInfo NoStgBinderInfo info2 = info2
386 combineStgBinderInfo info1 NoStgBinderInfo = info1
387 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
388 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
389 = StgBinderInfo (arg1 || arg2)
391 (std_heap1 || std_heap2)
392 (upd_heap1 || upd_heap2)
396 %************************************************************************
398 \subsection[Stg-case-alternatives]{STG case alternatives}
400 %************************************************************************
402 Just like in @CoreSyntax@ (except no type-world stuff).
405 data GenStgCaseAlts bndr occ
406 = StgAlgAlts Type -- so we can find out things about constructor family
407 [(Id, -- alts: data constructor,
408 [bndr], -- constructor's parameters,
409 [Bool], -- "use mask", same length as
410 -- parameters; a True in a
411 -- param's position if it is
413 GenStgExpr bndr occ)] -- ...right-hand side.
414 (GenStgCaseDefault bndr occ)
415 | StgPrimAlts Type -- so we can find out things about constructor family
416 [(Literal, -- alts: unboxed literal,
417 GenStgExpr bndr occ)] -- rhs.
418 (GenStgCaseDefault bndr occ)
420 data GenStgCaseDefault bndr occ
421 = StgNoDefault -- small con family: all
422 -- constructor accounted for
423 | StgBindDefault bndr -- form: var -> expr
424 Bool -- True <=> var is used in rhs
425 -- i.e., False <=> "_ -> expr"
426 (GenStgExpr bndr occ)
429 %************************************************************************
431 \subsection[Stg]{The Plain STG parameterisation}
433 %************************************************************************
435 This happens to be the only one we use at the moment.
438 type StgBinding = GenStgBinding Id Id
439 type StgArg = GenStgArg Id
440 type StgLiveVars = GenStgLiveVars Id
441 type StgExpr = GenStgExpr Id Id
442 type StgRhs = GenStgRhs Id Id
443 type StgCaseAlts = GenStgCaseAlts Id Id
444 type StgCaseDefault = GenStgCaseDefault Id Id
447 %************************************************************************
449 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
451 %************************************************************************
453 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
456 data UpdateFlag = ReEntrant | Updatable | SingleEntry
458 instance Outputable UpdateFlag where
460 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
463 %************************************************************************
465 \subsection[Stg-utility-functions]{Utility functions}
467 %************************************************************************
470 For doing interfaces, we want the exported top-level Ids from the
471 final pre-codegen STG code, so as to be sure we have the
472 latest/greatest pragma info.
475 collectFinalStgBinders
476 :: [StgBinding] -- input program
479 collectFinalStgBinders [] = []
480 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
481 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
484 %************************************************************************
486 \subsection[Stg-pretty-printing]{Pretty-printing}
488 %************************************************************************
490 Robin Popplestone asked for semi-colon separators on STG binds; here's
491 hoping he likes terminators instead... Ditto for case alternatives.
494 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
495 => GenStgBinding bndr bdee -> SDoc
497 pprGenStgBinding (StgNonRec bndr rhs)
498 = hang (hsep [ppr bndr, equals])
499 4 ((<>) (ppr rhs) semi)
501 pprGenStgBinding (StgCoerceBinding bndr occ)
502 = hang (hsep [ppr bndr, equals, ptext SLIT("{-Coerce-}")])
503 4 ((<>) (ppr occ) semi)
505 pprGenStgBinding (StgRec pairs)
506 = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
507 (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
509 ppr_bind (bndr, expr)
510 = hang (hsep [ppr bndr, equals])
511 4 ((<>) (ppr expr) semi)
513 pprStgBinding :: StgBinding -> SDoc
514 pprStgBinding bind = pprGenStgBinding bind
516 pprStgBindings :: [StgBinding] -> SDoc
517 pprStgBindings binds = vcat (map (pprGenStgBinding) binds)
521 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
524 instance (Outputable bndr, Outputable bdee, Ord bdee)
525 => Outputable (GenStgBinding bndr bdee) where
526 ppr = pprGenStgBinding
528 instance (Outputable bndr, Outputable bdee, Ord bdee)
529 => Outputable (GenStgExpr bndr bdee) where
532 instance (Outputable bndr, Outputable bdee, Ord bdee)
533 => Outputable (GenStgRhs bndr bdee) where
534 ppr rhs = pprStgRhs rhs
538 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
540 pprStgArg (StgVarArg var) = ppr var
541 pprStgArg (StgConArg con) = ppr con
542 pprStgArg (StgLitArg lit) = ppr lit
546 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
547 => GenStgExpr bndr bdee -> SDoc
549 pprStgExpr (StgApp func [] lvs)
550 = (<>) (ppr func) (pprStgLVs lvs)
553 pprStgExpr (StgApp func args lvs)
554 = hang ((<>) (ppr func) (pprStgLVs lvs))
555 4 (sep (map (ppr) args))
559 pprStgExpr (StgCon con args lvs)
560 = hcat [ (<>) (ppr con) (pprStgLVs lvs),
561 ptext SLIT("! ["), interppSP args, char ']' ]
563 pprStgExpr (StgPrim op args lvs)
564 = hcat [ ppr op, char '#', pprStgLVs lvs,
565 ptext SLIT(" ["), interppSP args, char ']' ]
569 -- special case: let v = <very specific thing>
575 -- Very special! Suspicious! (SLPJ)
577 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
580 (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
581 text (showCostCentre True{-as string-} cc),
583 ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
584 ppr upd_flag, ptext SLIT(" ["),
585 interppSP args, char ']'])
586 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
589 -- special case: let ... in let ...
591 pprStgExpr (StgLet bind expr@(StgLet _ _))
593 (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
597 pprStgExpr (StgLet bind expr)
598 = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
599 hang (ptext SLIT("} in ")) 2 (ppr expr)]
601 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
602 = sep [hang (ptext SLIT("let-no-escape {"))
603 2 (pprGenStgBinding bind),
604 hang ((<>) (ptext SLIT("} in "))
607 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
608 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
614 pprStgExpr (StgSCC ty cc expr)
615 = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre True{-as string-} cc)],
620 pprStgExpr (StgCase expr lvs_whole lvs_rhss uniq alts)
621 = sep [sep [ptext SLIT("case"),
622 nest 4 (hsep [pprStgExpr expr,
623 ifPprDebug (ptext SLIT("::") <> pp_ty alts)]),
627 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
628 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
629 ptext SLIT("]; uniq: "), pprUnique uniq])),
630 nest 2 (ppr_alts alts),
633 ppr_default StgNoDefault = empty
634 ppr_default (StgBindDefault bndr used expr)
635 = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr expr)
637 pp_binder = if used then ppr bndr else char '_'
639 pp_ty (StgAlgAlts ty _ _) = ppr ty
640 pp_ty (StgPrimAlts ty _ _) = ppr ty
642 ppr_alts (StgAlgAlts ty alts deflt)
643 = vcat [ vcat (map (ppr_bxd_alt) alts),
646 ppr_bxd_alt (con, params, use_mask, expr)
647 = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
648 4 ((<>) (ppr expr) semi)
650 ppr_alts (StgPrimAlts ty alts deflt)
651 = vcat [ vcat (map (ppr_ubxd_alt) alts),
654 ppr_ubxd_alt (lit, expr)
655 = hang (hsep [ppr lit, ptext SLIT("->")])
656 4 ((<>) (ppr expr) semi)
660 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
662 = getPprStyle $ \ sty ->
663 if userStyle sty || isEmptyUniqSet lvs then
666 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
670 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
671 => GenStgRhs bndr bdee -> SDoc
674 pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
675 = hcat [ text (showCostCentre True{-as String-} cc),
677 brackets (ifPprDebug (ppr free_var)),
678 ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
681 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
682 = hang (hcat [text (showCostCentre True{-as String-} cc),
684 brackets (ifPprDebug (interppSP free_vars)),
685 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
688 pprStgRhs (StgRhsCon cc con args)
689 = hcat [ text (showCostCentre True{-as String-} cc),
690 space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
694 pp_binder_info NoStgBinderInfo = empty
696 -- cases so boring that we print nothing
697 pp_binder_info (StgBinderInfo True b c d e) = empty
700 pp_binder_info (StgBinderInfo a b c d e)
701 = getPprStyle $ \ sty ->
702 if userStyle sty then
705 parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
708 Collect @IdInfo@ stuff that is most easily just snaffled straight
709 from the STG bindings.
712 stgArity :: StgRhs -> Int
714 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
715 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args