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,
38 collectFinalStgBinders
45 #include "HsVersions.h"
47 import CostCentre ( CostCentreStack, CostCentre )
48 import Id ( idPrimRep, Id )
49 import Const ( Con(..), DataCon, Literal,
50 conPrimRep, isLitLitLit )
51 import PrimRep ( PrimRep(..) )
54 import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
57 %************************************************************************
59 \subsection{@GenStgBinding@}
61 %************************************************************************
63 As usual, expressions are interesting; other things are boring. Here
64 are the boring things [except note the @GenStgRhs@], parameterised
65 with respect to binder and occurrence information (just as in
69 data GenStgBinding bndr occ
70 = StgNonRec bndr (GenStgRhs bndr occ)
71 | StgRec [(bndr, GenStgRhs bndr occ)]
74 %************************************************************************
76 \subsection{@GenStgArg@}
78 %************************************************************************
83 | StgConArg Con -- A literal or nullary data constructor
87 getArgPrimRep (StgVarArg local) = idPrimRep local
88 getArgPrimRep (StgConArg con) = conPrimRep con
90 isLitLitArg (StgConArg (Literal x)) = isLitLitLit x
94 %************************************************************************
96 \subsection{STG expressions}
98 %************************************************************************
100 The @GenStgExpr@ data type is parameterised on binder and occurrence
103 %************************************************************************
105 \subsubsection{@GenStgExpr@ application}
107 %************************************************************************
109 An application is of a function to a list of atoms [not expressions].
110 Operationally, we want to push the arguments on the stack and call the
111 function. (If the arguments were expressions, we would have to build
112 their closures first.)
114 There is no constructor for a lone variable; it would appear as
117 type GenStgLiveVars occ = UniqSet occ
119 data GenStgExpr bndr occ
122 [GenStgArg occ] -- arguments
124 -- NB: a literal is: StgApp <lit-atom> [] ...
127 %************************************************************************
129 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
131 %************************************************************************
133 There are a specialised forms of application, for
134 constructors, primitives, and literals.
136 | StgCon -- always saturated
140 Type -- Result type; this is needed for primops, where
141 -- we need to know the result type so that we can
142 -- assign result registers.
145 These forms are to do ``inline versions,'' as it were.
146 An example might be: @f x = x:[]@.
148 %************************************************************************
150 \subsubsection{@GenStgExpr@: case-expressions}
152 %************************************************************************
154 This has the same boxed/unboxed business as Core case expressions.
157 (GenStgExpr bndr occ)
158 -- the thing to examine
160 (GenStgLiveVars occ) -- Live vars of whole case
161 -- expression; i.e., those which mustn't be
164 (GenStgLiveVars occ) -- Live vars of RHSs;
165 -- i.e., those which must be saved before eval.
167 -- note that an alt's constructor's
168 -- binder-variables are NOT counted in the
169 -- free vars for the alt's RHS
171 bndr -- binds the result of evaluating the scrutinee
173 SRT -- The SRT for the continuation
175 (GenStgCaseAlts bndr occ)
178 %************************************************************************
180 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
182 %************************************************************************
184 The various forms of let(rec)-expression encode most of the
185 interesting things we want to do.
189 let-closure x = [free-vars] expr [args]
194 let x = (\free-vars -> \args -> expr) free-vars
196 \tr{args} may be empty (and is for most closures). It isn't under
197 circumstances like this:
203 let-closure x = [z] [y] (y+z)
205 The idea is that we compile code for @(y+z)@ in an environment in which
206 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
207 offset from the stack pointer.
209 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
213 let-constructor x = Constructor [args]
217 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
220 Letrec-expressions are essentially the same deal as
221 let-closure/let-constructor, so we use a common structure and
222 distinguish between them with an @is_recursive@ boolean flag.
226 let-unboxed u = an arbitrary arithmetic expression in unboxed values
229 All the stuff on the RHS must be fully evaluated. No function calls either!
231 (We've backed away from this toward case-expressions with
232 suitably-magical alts ...)
235 ~[Advanced stuff here! Not to start with, but makes pattern matching
236 generate more efficient code.]
239 let-escapes-not fail = expr
242 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
243 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
244 Rather than build a closure for @fail@, all we need do is to record the stack
245 level at the moment of the @let-escapes-not@; then entering @fail@ is just
246 a matter of adjusting the stack pointer back down to that point and entering
251 f x y = let z = huge-expression in
257 (A let-escapes-not is an @StgLetNoEscape@.)
260 We may eventually want:
262 let-literal x = Literal
266 (ToDo: is this obsolete?)
269 And so the code for let(rec)-things:
272 (GenStgBinding bndr occ) -- right hand sides (see below)
273 (GenStgExpr bndr occ) -- body
275 | StgLetNoEscape -- remember: ``advanced stuff''
276 (GenStgLiveVars occ) -- Live in the whole let-expression
277 -- Mustn't overwrite these stack slots
278 -- *Doesn't* include binders of the let(rec).
280 (GenStgLiveVars occ) -- Live in the right hand sides (only)
281 -- These are the ones which must be saved on
282 -- the stack if they aren't there already
283 -- *Does* include binders of the let(rec) if recursive.
285 (GenStgBinding bndr occ) -- right hand sides (see below)
286 (GenStgExpr bndr occ) -- body
289 %************************************************************************
291 \subsubsection{@GenStgExpr@: @scc@ expressions}
293 %************************************************************************
295 Finally for @scc@ expressions we introduce a new STG construct.
299 CostCentre -- label of SCC expression
300 (GenStgExpr bndr occ) -- scc expression
304 %************************************************************************
306 \subsection{STG right-hand sides}
308 %************************************************************************
310 Here's the rest of the interesting stuff for @StgLet@s; the first
311 flavour is for closures:
313 data GenStgRhs bndr occ
315 CostCentreStack -- CCS to be attached (default is CurrentCCS)
316 StgBinderInfo -- Info about how this binder is used (see below)
317 SRT -- The closures's SRT
318 [occ] -- non-global free vars; a list, rather than
319 -- a set, because order is important
320 UpdateFlag -- ReEntrant | Updatable | SingleEntry
321 [bndr] -- arguments; if empty, then not a function;
322 -- as above, order is important.
323 (GenStgExpr bndr occ) -- body
325 An example may be in order. Consider:
327 let t = \x -> \y -> ... x ... y ... p ... q in e
329 Pulling out the free vars and stylising somewhat, we get the equivalent:
331 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
333 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
334 offsets from @Node@ into the closure, and the code ptr for the closure
335 will be exactly that in parentheses above.
337 The second flavour of right-hand-side is for constructors (simple but important):
340 CostCentreStack -- CCS to be attached (default is CurrentCCS).
341 -- Top-level (static) ones will end up with
342 -- DontCareCCS, because we don't count static
343 -- data in heap profiles, and we don't set CCCS
344 -- from static closure.
345 DataCon -- constructor
346 [GenStgArg occ] -- args
349 Here's the @StgBinderInfo@ type, and its combining op:
354 Bool -- At least one occurrence as an argument
356 Bool -- At least one occurrence in an unsaturated application
358 Bool -- This thing (f) has at least occurrence of the form:
359 -- x = [..] \u [] -> f a b c
360 -- where the application is saturated
362 Bool -- Ditto for non-updatable x.
364 Bool -- At least one fake application occurrence, that is
365 -- an StgApp f args where args is an empty list
366 -- This is due to the fact that we do not have a
367 -- StgVar constructor.
368 -- Used by the lambda lifter.
369 -- True => "at least one unsat app" is True too
371 stgArgOcc = StgBinderInfo True False False False False
372 stgUnsatOcc = StgBinderInfo False True False False False
373 stgStdHeapOcc = StgBinderInfo False False True False False
374 stgNoUpdHeapOcc = StgBinderInfo False False False True False
375 stgNormalOcc = StgBinderInfo False False False False False
376 -- [Andre] can't think of a good name for the last one.
377 stgFakeFunAppOcc = StgBinderInfo False True False False True
379 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
381 combineStgBinderInfo NoStgBinderInfo info2 = info2
382 combineStgBinderInfo info1 NoStgBinderInfo = info1
383 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
384 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
385 = StgBinderInfo (arg1 || arg2)
387 (std_heap1 || std_heap2)
388 (upd_heap1 || upd_heap2)
392 %************************************************************************
394 \subsection[Stg-case-alternatives]{STG case alternatives}
396 %************************************************************************
398 Just like in @CoreSyntax@ (except no type-world stuff).
401 data GenStgCaseAlts bndr occ
402 = StgAlgAlts Type -- so we can find out things about constructor family
403 [(DataCon, -- alts: data constructor,
404 [bndr], -- constructor's parameters,
405 [Bool], -- "use mask", same length as
406 -- parameters; a True in a
407 -- param's position if it is
409 GenStgExpr bndr occ)] -- ...right-hand side.
410 (GenStgCaseDefault bndr occ)
411 | StgPrimAlts Type -- so we can find out things about constructor family
412 [(Literal, -- alts: unboxed literal,
413 GenStgExpr bndr occ)] -- rhs.
414 (GenStgCaseDefault bndr occ)
416 data GenStgCaseDefault bndr occ
417 = StgNoDefault -- small con family: all
418 -- constructor accounted for
419 | StgBindDefault (GenStgExpr bndr occ)
422 %************************************************************************
424 \subsection[Stg]{The Plain STG parameterisation}
426 %************************************************************************
428 This happens to be the only one we use at the moment.
431 type StgBinding = GenStgBinding Id Id
432 type StgArg = GenStgArg Id
433 type StgLiveVars = GenStgLiveVars Id
434 type StgExpr = GenStgExpr Id Id
435 type StgRhs = GenStgRhs Id Id
436 type StgCaseAlts = GenStgCaseAlts Id Id
437 type StgCaseDefault = GenStgCaseDefault Id Id
440 %************************************************************************
442 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
444 %************************************************************************
446 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
448 A @ReEntrant@ closure may be entered multiple times, but should not be
449 updated or blackholed. An @Updatable@ closure should be updated after
450 evaluation (and may be blackholed during evaluation). A @SingleEntry@
451 closure will only be entered once, and so need not be updated but may
452 safely be blackholed.
455 data UpdateFlag = ReEntrant | Updatable | SingleEntry
457 instance Outputable UpdateFlag where
459 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
461 isUpdatable ReEntrant = False
462 isUpdatable SingleEntry = False
463 isUpdatable Updatable = True
466 %************************************************************************
468 \subsubsection[Static Reference Tables]{@SRT@}
470 %************************************************************************
472 There is one SRT per top-level function group. Each local binding and
473 case expression within this binding group has a subrange of the whole
474 SRT, expressed as an offset and length.
478 | SRT !Int{-offset-} !Int{-length-}
483 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
484 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
487 %************************************************************************
489 \subsection[Stg-utility-functions]{Utility functions}
491 %************************************************************************
494 For doing interfaces, we want the exported top-level Ids from the
495 final pre-codegen STG code, so as to be sure we have the
496 latest/greatest pragma info.
499 collectFinalStgBinders
500 :: [StgBinding] -- input program
503 collectFinalStgBinders [] = []
504 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
505 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
508 %************************************************************************
510 \subsection[Stg-pretty-printing]{Pretty-printing}
512 %************************************************************************
514 Robin Popplestone asked for semi-colon separators on STG binds; here's
515 hoping he likes terminators instead... Ditto for case alternatives.
518 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
519 => GenStgBinding bndr bdee -> SDoc
521 pprGenStgBinding (StgNonRec bndr rhs)
522 = hang (hsep [ppr bndr, equals])
523 4 ((<>) (ppr rhs) semi)
525 pprGenStgBinding (StgRec pairs)
526 = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
527 (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
529 ppr_bind (bndr, expr)
530 = hang (hsep [ppr bndr, equals])
531 4 ((<>) (ppr expr) semi)
533 pprStgBinding :: StgBinding -> SDoc
534 pprStgBinding bind = pprGenStgBinding bind
536 pprStgBindings :: [StgBinding] -> SDoc
537 pprStgBindings binds = vcat (map pprGenStgBinding binds)
539 pprGenStgBindingWithSRT
540 :: (Outputable bndr, Outputable bdee, Ord bdee)
541 => (GenStgBinding bndr bdee,[Id]) -> SDoc
543 pprGenStgBindingWithSRT (bind,srt)
544 = vcat [ pprGenStgBinding bind,
545 ptext SLIT("SRT: ") <> ppr srt ]
547 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
548 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
552 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
555 instance (Outputable bndr, Outputable bdee, Ord bdee)
556 => Outputable (GenStgBinding bndr bdee) where
557 ppr = pprGenStgBinding
559 instance (Outputable bndr, Outputable bdee, Ord bdee)
560 => Outputable (GenStgExpr bndr bdee) where
563 instance (Outputable bndr, Outputable bdee, Ord bdee)
564 => Outputable (GenStgRhs bndr bdee) where
565 ppr rhs = pprStgRhs rhs
569 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
571 pprStgArg (StgVarArg var) = ppr var
572 pprStgArg (StgConArg con) = ppr con
576 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
577 => GenStgExpr bndr bdee -> SDoc
579 pprStgExpr (StgApp func []) = ppr func
582 pprStgExpr (StgApp func args)
584 4 (sep (map (ppr) args))
588 pprStgExpr (StgCon con args _)
589 = hsep [ ppr con, brackets (interppSP args)]
593 -- special case: let v = <very specific thing>
599 -- Very special! Suspicious! (SLPJ)
601 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
604 (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
607 ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
608 ppr upd_flag, ptext SLIT(" ["),
609 interppSP args, char ']'])
610 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
613 -- special case: let ... in let ...
615 pprStgExpr (StgLet bind expr@(StgLet _ _))
617 (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
621 pprStgExpr (StgLet bind expr)
622 = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
623 hang (ptext SLIT("} in ")) 2 (ppr expr)]
625 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
626 = sep [hang (ptext SLIT("let-no-escape {"))
627 2 (pprGenStgBinding bind),
628 hang ((<>) (ptext SLIT("} in "))
631 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
632 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
638 pprStgExpr (StgSCC cc expr)
639 = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
644 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
645 = sep [sep [ptext SLIT("case"),
646 nest 4 (hsep [pprStgExpr expr,
647 ifPprDebug (dcolon <+> pp_ty alts)]),
648 ptext SLIT("of"), ppr bndr, char '{'],
651 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
652 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
655 nest 2 (ppr_alts alts),
658 ppr_default StgNoDefault = empty
659 ppr_default (StgBindDefault expr)
660 = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
662 pp_ty (StgAlgAlts ty _ _) = ppr ty
663 pp_ty (StgPrimAlts ty _ _) = ppr ty
665 ppr_alts (StgAlgAlts ty alts deflt)
666 = vcat [ vcat (map (ppr_bxd_alt) alts),
669 ppr_bxd_alt (con, params, use_mask, expr)
670 = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
671 4 ((<>) (ppr expr) semi)
673 ppr_alts (StgPrimAlts ty alts deflt)
674 = vcat [ vcat (map (ppr_ubxd_alt) alts),
677 ppr_ubxd_alt (lit, expr)
678 = hang (hsep [ppr lit, ptext SLIT("->")])
679 4 ((<>) (ppr expr) semi)
683 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
685 = getPprStyle $ \ sty ->
686 if userStyle sty || isEmptyUniqSet lvs then
689 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
693 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
694 => GenStgRhs bndr bdee -> SDoc
697 pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
701 brackets (ifPprDebug (ppr free_var)),
702 ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
705 pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
706 = hang (hcat [ppr cc,
709 brackets (ifPprDebug (interppSP free_vars)),
710 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
713 pprStgRhs (StgRhsCon cc con args)
715 space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
717 pprMaybeSRT (NoSRT) = empty
718 pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
722 pp_binder_info NoStgBinderInfo = empty
724 -- cases so boring that we print nothing
725 pp_binder_info (StgBinderInfo True b c d e) = empty
728 pp_binder_info (StgBinderInfo a b c d e)
729 = getPprStyle $ \ sty ->
730 if userStyle sty then
733 parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
736 Collect @IdInfo@ stuff that is most easily just snaffled straight
737 from the STG bindings.
740 stgArity :: StgRhs -> Int
742 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
743 stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args