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{@StgLam@}
152 %************************************************************************
154 StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished
155 it encodes (\x -> e) as (let f = \x -> e in f)
159 Type -- Type of whole lambda (useful when making a binder for it)
161 StgExpr -- Body of lambda
165 %************************************************************************
167 \subsubsection{@GenStgExpr@: case-expressions}
169 %************************************************************************
171 This has the same boxed/unboxed business as Core case expressions.
174 (GenStgExpr bndr occ)
175 -- the thing to examine
177 (GenStgLiveVars occ) -- Live vars of whole case
178 -- expression; i.e., those which mustn't be
181 (GenStgLiveVars occ) -- Live vars of RHSs;
182 -- i.e., those which must be saved before eval.
184 -- note that an alt's constructor's
185 -- binder-variables are NOT counted in the
186 -- free vars for the alt's RHS
188 bndr -- binds the result of evaluating the scrutinee
190 SRT -- The SRT for the continuation
192 (GenStgCaseAlts bndr occ)
195 %************************************************************************
197 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
199 %************************************************************************
201 The various forms of let(rec)-expression encode most of the
202 interesting things we want to do.
206 let-closure x = [free-vars] expr [args]
211 let x = (\free-vars -> \args -> expr) free-vars
213 \tr{args} may be empty (and is for most closures). It isn't under
214 circumstances like this:
220 let-closure x = [z] [y] (y+z)
222 The idea is that we compile code for @(y+z)@ in an environment in which
223 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
224 offset from the stack pointer.
226 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
230 let-constructor x = Constructor [args]
234 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
237 Letrec-expressions are essentially the same deal as
238 let-closure/let-constructor, so we use a common structure and
239 distinguish between them with an @is_recursive@ boolean flag.
243 let-unboxed u = an arbitrary arithmetic expression in unboxed values
246 All the stuff on the RHS must be fully evaluated. No function calls either!
248 (We've backed away from this toward case-expressions with
249 suitably-magical alts ...)
252 ~[Advanced stuff here! Not to start with, but makes pattern matching
253 generate more efficient code.]
256 let-escapes-not fail = expr
259 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
260 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
261 Rather than build a closure for @fail@, all we need do is to record the stack
262 level at the moment of the @let-escapes-not@; then entering @fail@ is just
263 a matter of adjusting the stack pointer back down to that point and entering
268 f x y = let z = huge-expression in
274 (A let-escapes-not is an @StgLetNoEscape@.)
277 We may eventually want:
279 let-literal x = Literal
283 (ToDo: is this obsolete?)
286 And so the code for let(rec)-things:
289 (GenStgBinding bndr occ) -- right hand sides (see below)
290 (GenStgExpr bndr occ) -- body
292 | StgLetNoEscape -- remember: ``advanced stuff''
293 (GenStgLiveVars occ) -- Live in the whole let-expression
294 -- Mustn't overwrite these stack slots
295 -- *Doesn't* include binders of the let(rec).
297 (GenStgLiveVars occ) -- Live in the right hand sides (only)
298 -- These are the ones which must be saved on
299 -- the stack if they aren't there already
300 -- *Does* include binders of the let(rec) if recursive.
302 (GenStgBinding bndr occ) -- right hand sides (see below)
303 (GenStgExpr bndr occ) -- body
306 %************************************************************************
308 \subsubsection{@GenStgExpr@: @scc@ expressions}
310 %************************************************************************
312 Finally for @scc@ expressions we introduce a new STG construct.
316 CostCentre -- label of SCC expression
317 (GenStgExpr bndr occ) -- scc expression
321 %************************************************************************
323 \subsection{STG right-hand sides}
325 %************************************************************************
327 Here's the rest of the interesting stuff for @StgLet@s; the first
328 flavour is for closures:
330 data GenStgRhs bndr occ
332 CostCentreStack -- CCS to be attached (default is CurrentCCS)
333 StgBinderInfo -- Info about how this binder is used (see below)
334 SRT -- The closures's SRT
335 [occ] -- non-global free vars; a list, rather than
336 -- a set, because order is important
337 UpdateFlag -- ReEntrant | Updatable | SingleEntry
338 [bndr] -- arguments; if empty, then not a function;
339 -- as above, order is important.
340 (GenStgExpr bndr occ) -- body
342 An example may be in order. Consider:
344 let t = \x -> \y -> ... x ... y ... p ... q in e
346 Pulling out the free vars and stylising somewhat, we get the equivalent:
348 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
350 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
351 offsets from @Node@ into the closure, and the code ptr for the closure
352 will be exactly that in parentheses above.
354 The second flavour of right-hand-side is for constructors (simple but important):
357 CostCentreStack -- CCS to be attached (default is CurrentCCS).
358 -- Top-level (static) ones will end up with
359 -- DontCareCCS, because we don't count static
360 -- data in heap profiles, and we don't set CCCS
361 -- from static closure.
362 DataCon -- constructor
363 [GenStgArg occ] -- args
366 Here's the @StgBinderInfo@ type, and its combining op:
371 Bool -- At least one occurrence as an argument
373 Bool -- At least one occurrence in an unsaturated application
375 Bool -- This thing (f) has at least occurrence of the form:
376 -- x = [..] \u [] -> f a b c
377 -- where the application is saturated
379 Bool -- Ditto for non-updatable x.
381 Bool -- At least one fake application occurrence, that is
382 -- an StgApp f args where args is an empty list
383 -- This is due to the fact that we do not have a
384 -- StgVar constructor.
385 -- Used by the lambda lifter.
386 -- True => "at least one unsat app" is True too
388 stgArgOcc = StgBinderInfo True False False False False
389 stgUnsatOcc = StgBinderInfo False True False False False
390 stgStdHeapOcc = StgBinderInfo False False True False False
391 stgNoUpdHeapOcc = StgBinderInfo False False False True False
392 stgNormalOcc = StgBinderInfo False False False False False
393 -- [Andre] can't think of a good name for the last one.
394 stgFakeFunAppOcc = StgBinderInfo False True False False True
396 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
398 combineStgBinderInfo NoStgBinderInfo info2 = info2
399 combineStgBinderInfo info1 NoStgBinderInfo = info1
400 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
401 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
402 = StgBinderInfo (arg1 || arg2)
404 (std_heap1 || std_heap2)
405 (upd_heap1 || upd_heap2)
409 %************************************************************************
411 \subsection[Stg-case-alternatives]{STG case alternatives}
413 %************************************************************************
415 Just like in @CoreSyntax@ (except no type-world stuff).
418 data GenStgCaseAlts bndr occ
419 = StgAlgAlts Type -- so we can find out things about constructor family
420 [(DataCon, -- alts: data constructor,
421 [bndr], -- constructor's parameters,
422 [Bool], -- "use mask", same length as
423 -- parameters; a True in a
424 -- param's position if it is
426 GenStgExpr bndr occ)] -- ...right-hand side.
427 (GenStgCaseDefault bndr occ)
428 | StgPrimAlts Type -- so we can find out things about constructor family
429 [(Literal, -- alts: unboxed literal,
430 GenStgExpr bndr occ)] -- rhs.
431 (GenStgCaseDefault bndr occ)
433 data GenStgCaseDefault bndr occ
434 = StgNoDefault -- small con family: all
435 -- constructor accounted for
436 | StgBindDefault (GenStgExpr bndr occ)
439 %************************************************************************
441 \subsection[Stg]{The Plain STG parameterisation}
443 %************************************************************************
445 This happens to be the only one we use at the moment.
448 type StgBinding = GenStgBinding Id Id
449 type StgArg = GenStgArg Id
450 type StgLiveVars = GenStgLiveVars Id
451 type StgExpr = GenStgExpr Id Id
452 type StgRhs = GenStgRhs Id Id
453 type StgCaseAlts = GenStgCaseAlts Id Id
454 type StgCaseDefault = GenStgCaseDefault Id Id
457 %************************************************************************
459 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
461 %************************************************************************
463 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
465 A @ReEntrant@ closure may be entered multiple times, but should not be
466 updated or blackholed. An @Updatable@ closure should be updated after
467 evaluation (and may be blackholed during evaluation). A @SingleEntry@
468 closure will only be entered once, and so need not be updated but may
469 safely be blackholed.
472 data UpdateFlag = ReEntrant | Updatable | SingleEntry
474 instance Outputable UpdateFlag where
476 = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
478 isUpdatable ReEntrant = False
479 isUpdatable SingleEntry = False
480 isUpdatable Updatable = True
483 %************************************************************************
485 \subsubsection[Static Reference Tables]{@SRT@}
487 %************************************************************************
489 There is one SRT per top-level function group. Each local binding and
490 case expression within this binding group has a subrange of the whole
491 SRT, expressed as an offset and length.
495 | SRT !Int{-offset-} !Int{-length-}
500 pprSRT (NoSRT) = ptext SLIT("_no_srt_")
501 pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
504 %************************************************************************
506 \subsection[Stg-utility-functions]{Utility functions}
508 %************************************************************************
511 For doing interfaces, we want the exported top-level Ids from the
512 final pre-codegen STG code, so as to be sure we have the
513 latest/greatest pragma info.
516 collectFinalStgBinders
517 :: [StgBinding] -- input program
520 collectFinalStgBinders [] = []
521 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
522 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
525 %************************************************************************
527 \subsection[Stg-pretty-printing]{Pretty-printing}
529 %************************************************************************
531 Robin Popplestone asked for semi-colon separators on STG binds; here's
532 hoping he likes terminators instead... Ditto for case alternatives.
535 pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
536 => GenStgBinding bndr bdee -> SDoc
538 pprGenStgBinding (StgNonRec bndr rhs)
539 = hang (hsep [ppr bndr, equals])
540 4 ((<>) (ppr rhs) semi)
542 pprGenStgBinding (StgRec pairs)
543 = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
544 (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
546 ppr_bind (bndr, expr)
547 = hang (hsep [ppr bndr, equals])
548 4 ((<>) (ppr expr) semi)
550 pprStgBinding :: StgBinding -> SDoc
551 pprStgBinding bind = pprGenStgBinding bind
553 pprStgBindings :: [StgBinding] -> SDoc
554 pprStgBindings binds = vcat (map pprGenStgBinding binds)
556 pprGenStgBindingWithSRT
557 :: (Outputable bndr, Outputable bdee, Ord bdee)
558 => (GenStgBinding bndr bdee,[Id]) -> SDoc
560 pprGenStgBindingWithSRT (bind,srt)
561 = vcat [ pprGenStgBinding bind,
562 ptext SLIT("SRT: ") <> ppr srt ]
564 pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
565 pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
569 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
572 instance (Outputable bndr, Outputable bdee, Ord bdee)
573 => Outputable (GenStgBinding bndr bdee) where
574 ppr = pprGenStgBinding
576 instance (Outputable bndr, Outputable bdee, Ord bdee)
577 => Outputable (GenStgExpr bndr bdee) where
580 instance (Outputable bndr, Outputable bdee, Ord bdee)
581 => Outputable (GenStgRhs bndr bdee) where
582 ppr rhs = pprStgRhs rhs
586 pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
588 pprStgArg (StgVarArg var) = ppr var
589 pprStgArg (StgConArg con) = ppr con
593 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
594 => GenStgExpr bndr bdee -> SDoc
596 pprStgExpr (StgApp func []) = ppr func
599 pprStgExpr (StgApp func args)
601 4 (sep (map (ppr) args))
605 pprStgExpr (StgCon con args _)
606 = hsep [ ppr con, brackets (interppSP args)]
608 pprStgExpr (StgLam _ bndrs body)
609 =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
614 -- special case: let v = <very specific thing>
620 -- Very special! Suspicious! (SLPJ)
622 pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
625 (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
628 ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
629 ppr upd_flag, ptext SLIT(" ["),
630 interppSP args, char ']'])
631 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
634 -- special case: let ... in let ...
636 pprStgExpr (StgLet bind expr@(StgLet _ _))
638 (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
642 pprStgExpr (StgLet bind expr)
643 = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
644 hang (ptext SLIT("} in ")) 2 (ppr expr)]
646 pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
647 = sep [hang (ptext SLIT("let-no-escape {"))
648 2 (pprGenStgBinding bind),
649 hang ((<>) (ptext SLIT("} in "))
652 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
653 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
659 pprStgExpr (StgSCC cc expr)
660 = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
665 pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
666 = sep [sep [ptext SLIT("case"),
667 nest 4 (hsep [pprStgExpr expr,
668 ifPprDebug (dcolon <+> pp_ty alts)]),
669 ptext SLIT("of"), ppr bndr, char '{'],
672 hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
673 ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
676 nest 2 (ppr_alts alts),
679 ppr_default StgNoDefault = empty
680 ppr_default (StgBindDefault expr)
681 = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
683 pp_ty (StgAlgAlts ty _ _) = ppr ty
684 pp_ty (StgPrimAlts ty _ _) = ppr ty
686 ppr_alts (StgAlgAlts ty alts deflt)
687 = vcat [ vcat (map (ppr_bxd_alt) alts),
690 ppr_bxd_alt (con, params, use_mask, expr)
691 = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
692 4 ((<>) (ppr expr) semi)
694 ppr_alts (StgPrimAlts ty alts deflt)
695 = vcat [ vcat (map (ppr_ubxd_alt) alts),
698 ppr_ubxd_alt (lit, expr)
699 = hang (hsep [ppr lit, ptext SLIT("->")])
700 4 ((<>) (ppr expr) semi)
704 pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
706 = getPprStyle $ \ sty ->
707 if userStyle sty || isEmptyUniqSet lvs then
710 hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
714 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
715 => GenStgRhs bndr bdee -> SDoc
718 pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
722 brackets (ifPprDebug (ppr free_var)),
723 ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
726 pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
727 = hang (hcat [ppr cc,
730 brackets (ifPprDebug (interppSP free_vars)),
731 ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
734 pprStgRhs (StgRhsCon cc con args)
736 space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
738 pprMaybeSRT (NoSRT) = empty
739 pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
743 pp_binder_info NoStgBinderInfo = empty
745 -- cases so boring that we print nothing
746 pp_binder_info (StgBinderInfo True b c d e) = empty
749 pp_binder_info (StgBinderInfo a b c d e)
750 = getPprStyle $ \ sty ->
751 if userStyle sty then
754 parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
757 Collect @IdInfo@ stuff that is most easily just snaffled straight
758 from the STG bindings.
761 stgArity :: StgRhs -> Int
763 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
764 stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args