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 )
43 import Id ( idPrimRep, SYN_IE(DataCon), GenId{-instance NamedThing-} )
44 import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
45 import Name ( pprNonSym )
46 import Outputable ( ifPprDebug, interppSP, interpp'SP,
47 Outputable(..){-instance * Bool-}
49 import PprStyle ( PprStyle(..) )
50 import PprType ( GenType{-instance Outputable-} )
51 import Pretty -- all of it
52 import PrimOp ( PrimOp{-instance Outputable-} )
53 import Unique ( pprUnique )
54 import UniqSet ( isEmptyUniqSet, uniqSetToList, SYN_IE(UniqSet) )
58 %************************************************************************
60 \subsection{@GenStgBinding@}
62 %************************************************************************
64 As usual, expressions are interesting; other things are boring. Here
65 are the boring things [except note the @GenStgRhs@], parameterised
66 with respect to binder and occurrence information (just as in
70 data GenStgBinding bndr occ
71 = StgNonRec bndr (GenStgRhs bndr occ)
72 | StgRec [(bndr, GenStgRhs bndr occ)]
73 | StgCoerceBinding bndr occ
76 %************************************************************************
78 \subsection{@GenStgArg@}
80 %************************************************************************
86 | StgConArg DataCon -- A nullary data constructor
90 getArgPrimRep (StgVarArg local) = idPrimRep local
91 getArgPrimRep (StgConArg con) = idPrimRep con
92 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
94 isLitLitArg (StgLitArg x) = isLitLitLit x
98 %************************************************************************
100 \subsection{STG expressions}
102 %************************************************************************
104 The @GenStgExpr@ data type is parameterised on binder and occurrence
107 %************************************************************************
109 \subsubsection{@GenStgExpr@ application}
111 %************************************************************************
113 An application is of a function to a list of atoms [not expressions].
114 Operationally, we want to push the arguments on the stack and call the
115 function. (If the arguments were expressions, we would have to build
116 their closures first.)
118 There is no constructor for a lone variable; it would appear as
121 type GenStgLiveVars occ = UniqSet occ
123 data GenStgExpr bndr occ
125 (GenStgArg occ) -- function
126 [GenStgArg occ] -- arguments
127 (GenStgLiveVars occ) -- Live vars in continuation; ie not
128 -- including the function and args
130 -- NB: a literal is: StgApp <lit-atom> [] ...
133 %************************************************************************
135 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
137 %************************************************************************
139 There are two specialised forms of application, for
140 constructors and primitives.
142 | StgCon -- always saturated
143 Id -- data constructor
145 (GenStgLiveVars occ) -- Live vars in continuation; ie not
146 -- including the constr and args
148 | StgPrim -- always saturated
151 (GenStgLiveVars occ) -- Live vars in continuation; ie not
152 -- including the op and args
154 These forms are to do ``inline versions,'' as it were.
155 An example might be: @f x = x:[]@.
157 %************************************************************************
159 \subsubsection{@GenStgExpr@: case-expressions}
161 %************************************************************************
163 This has the same boxed/unboxed business as Core case expressions.
166 (GenStgExpr bndr occ)
167 -- the thing to examine
169 (GenStgLiveVars occ) -- Live vars of whole case
170 -- expression; i.e., those which mustn't be
173 (GenStgLiveVars occ) -- Live vars of RHSs;
174 -- i.e., those which must be saved before eval.
176 -- note that an alt's constructor's
177 -- binder-variables are NOT counted in the
178 -- free vars for the alt's RHS
180 Unique -- Occasionally needed to compile case
181 -- statements, as the uniq for a local
182 -- variable to hold the tag of a primop with
185 (GenStgCaseAlts bndr occ)
188 %************************************************************************
190 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
192 %************************************************************************
194 The various forms of let(rec)-expression encode most of the
195 interesting things we want to do.
199 let-closure x = [free-vars] expr [args]
204 let x = (\free-vars -> \args -> expr) free-vars
206 \tr{args} may be empty (and is for most closures). It isn't under
207 circumstances like this:
213 let-closure x = [z] [y] (y+z)
215 The idea is that we compile code for @(y+z)@ in an environment in which
216 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
217 offset from the stack pointer.
219 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
223 let-constructor x = Constructor [args]
227 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
230 Letrec-expressions are essentially the same deal as
231 let-closure/let-constructor, so we use a common structure and
232 distinguish between them with an @is_recursive@ boolean flag.
236 let-unboxed u = an arbitrary arithmetic expression in unboxed values
239 All the stuff on the RHS must be fully evaluated. No function calls either!
241 (We've backed away from this toward case-expressions with
242 suitably-magical alts ...)
245 ~[Advanced stuff here! Not to start with, but makes pattern matching
246 generate more efficient code.]
249 let-escapes-not fail = expr
252 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
253 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
254 Rather than build a closure for @fail@, all we need do is to record the stack
255 level at the moment of the @let-escapes-not@; then entering @fail@ is just
256 a matter of adjusting the stack pointer back down to that point and entering
261 f x y = let z = huge-expression in
267 (A let-escapes-not is an @StgLetNoEscape@.)
270 We may eventually want:
272 let-literal x = Literal
276 (ToDo: is this obsolete?)
279 And so the code for let(rec)-things:
282 (GenStgBinding bndr occ) -- right hand sides (see below)
283 (GenStgExpr bndr occ) -- body
285 | StgLetNoEscape -- remember: ``advanced stuff''
286 (GenStgLiveVars occ) -- Live in the whole let-expression
287 -- Mustn't overwrite these stack slots
288 -- *Doesn't* include binders of the let(rec).
290 (GenStgLiveVars occ) -- Live in the right hand sides (only)
291 -- These are the ones which must be saved on
292 -- the stack if they aren't there already
293 -- *Does* include binders of the let(rec) if recursive.
295 (GenStgBinding bndr occ) -- right hand sides (see below)
296 (GenStgExpr bndr occ) -- body
299 %************************************************************************
301 \subsubsection{@GenStgExpr@: @scc@ expressions}
303 %************************************************************************
305 Finally for @scc@ expressions we introduce a new STG construct.
309 Type -- the type of the body
310 CostCentre -- label of SCC expression
311 (GenStgExpr bndr occ) -- scc expression
315 %************************************************************************
317 \subsection{STG right-hand sides}
319 %************************************************************************
321 Here's the rest of the interesting stuff for @StgLet@s; the first
322 flavour is for closures:
324 data GenStgRhs bndr occ
326 CostCentre -- cost centre to be attached (default is CCC)
327 StgBinderInfo -- Info about how this binder is used (see below)
328 [occ] -- non-global free vars; a list, rather than
329 -- a set, because order is important
330 UpdateFlag -- ReEntrant | Updatable | SingleEntry
331 [bndr] -- arguments; if empty, then not a function;
332 -- as above, order is important
333 (GenStgExpr bndr occ) -- body
335 An example may be in order. Consider:
337 let t = \x -> \y -> ... x ... y ... p ... q in e
339 Pulling out the free vars and stylising somewhat, we get the equivalent:
341 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
343 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
344 offsets from @Node@ into the closure, and the code ptr for the closure
345 will be exactly that in parentheses above.
347 The second flavour of right-hand-side is for constructors (simple but important):
350 CostCentre -- Cost centre to be attached (default is CCC).
351 -- Top-level (static) ones will end up with
352 -- DontCareCC, because we don't count static
353 -- data in heap profiles, and we don't set CCC
354 -- from static closure.
356 [GenStgArg occ] -- args
359 Here's the @StgBinderInfo@ type, and its combining op:
364 Bool -- At least one occurrence as an argument
366 Bool -- At least one occurrence in an unsaturated application
368 Bool -- This thing (f) has at least occurrence of the form:
369 -- x = [..] \u [] -> f a b c
370 -- where the application is saturated
372 Bool -- Ditto for non-updatable x.
374 Bool -- At least one fake application occurrence, that is
375 -- an StgApp f args where args is an empty list
376 -- This is due to the fact that we do not have a
377 -- StgVar constructor.
378 -- Used by the lambda lifter.
379 -- True => "at least one unsat app" is True too
381 stgArgOcc = StgBinderInfo True False False False False
382 stgUnsatOcc = StgBinderInfo False True False False False
383 stgStdHeapOcc = StgBinderInfo False False True False False
384 stgNoUpdHeapOcc = StgBinderInfo False False False True False
385 stgNormalOcc = StgBinderInfo False False False False False
386 -- [Andre] can't think of a good name for the last one.
387 stgFakeFunAppOcc = StgBinderInfo False True False False True
389 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
391 combineStgBinderInfo NoStgBinderInfo info2 = info2
392 combineStgBinderInfo info1 NoStgBinderInfo = info1
393 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
394 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
395 = StgBinderInfo (arg1 || arg2)
397 (std_heap1 || std_heap2)
398 (upd_heap1 || upd_heap2)
402 %************************************************************************
404 \subsection[Stg-case-alternatives]{STG case alternatives}
406 %************************************************************************
408 Just like in @CoreSyntax@ (except no type-world stuff).
411 data GenStgCaseAlts bndr occ
412 = StgAlgAlts Type -- so we can find out things about constructor family
413 [(Id, -- alts: data constructor,
414 [bndr], -- constructor's parameters,
415 [Bool], -- "use mask", same length as
416 -- parameters; a True in a
417 -- param's position if it is
419 GenStgExpr bndr occ)] -- ...right-hand side.
420 (GenStgCaseDefault bndr occ)
421 | StgPrimAlts Type -- so we can find out things about constructor family
422 [(Literal, -- alts: unboxed literal,
423 GenStgExpr bndr occ)] -- rhs.
424 (GenStgCaseDefault bndr occ)
426 data GenStgCaseDefault bndr occ
427 = StgNoDefault -- small con family: all
428 -- constructor accounted for
429 | StgBindDefault bndr -- form: var -> expr
430 Bool -- True <=> var is used in rhs
431 -- i.e., False <=> "_ -> expr"
432 (GenStgExpr bndr occ)
435 %************************************************************************
437 \subsection[Stg]{The Plain STG parameterisation}
439 %************************************************************************
441 This happens to be the only one we use at the moment.
444 type StgBinding = GenStgBinding Id Id
445 type StgArg = GenStgArg Id
446 type StgLiveVars = GenStgLiveVars Id
447 type StgExpr = GenStgExpr Id Id
448 type StgRhs = GenStgRhs Id Id
449 type StgCaseAlts = GenStgCaseAlts Id Id
450 type StgCaseDefault = GenStgCaseDefault Id Id
453 %************************************************************************
455 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
457 %************************************************************************
459 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
462 data UpdateFlag = ReEntrant | Updatable | SingleEntry
464 instance Outputable UpdateFlag where
466 = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
469 %************************************************************************
471 \subsection[Stg-utility-functions]{Utility functions}
473 %************************************************************************
476 For doing interfaces, we want the exported top-level Ids from the
477 final pre-codegen STG code, so as to be sure we have the
478 latest/greatest pragma info.
481 collectFinalStgBinders
482 :: [StgBinding] -- input program
485 collectFinalStgBinders [] = []
486 collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
487 collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
490 %************************************************************************
492 \subsection[Stg-pretty-printing]{Pretty-printing}
494 %************************************************************************
496 Robin Popplestone asked for semi-colon separators on STG binds; here's
497 hoping he likes terminators instead... Ditto for case alternatives.
500 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
501 PprStyle -> GenStgBinding bndr bdee -> Pretty
503 pprStgBinding sty (StgNonRec bndr rhs)
504 = ppHang (ppCat [ppr sty bndr, ppEquals])
505 4 (ppBeside (ppr sty rhs) ppSemi)
507 pprStgBinding sty (StgCoerceBinding bndr occ)
508 = ppHang (ppCat [ppr sty bndr, ppEquals, ppPStr SLIT("{-Coerce-}")])
509 4 (ppBeside (ppr sty occ) ppSemi)
511 pprStgBinding sty (StgRec pairs)
512 = ppAboves ((ifPprDebug sty (ppPStr SLIT("{- StgRec (begin) -}"))) :
513 (map (ppr_bind sty) pairs) ++ [(ifPprDebug sty (ppPStr SLIT("{- StgRec (end) -}")))])
515 ppr_bind sty (bndr, expr)
516 = ppHang (ppCat [ppr sty bndr, ppEquals])
517 4 (ppBeside (ppr sty expr) ppSemi)
519 pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
520 pprPlainStgBinding sty b = pprStgBinding sty b
524 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
527 instance (Outputable bndr, Outputable bdee, Ord bdee)
528 => Outputable (GenStgBinding bndr bdee) where
531 instance (Outputable bndr, Outputable bdee, Ord bdee)
532 => Outputable (GenStgExpr bndr bdee) where
535 instance (Outputable bndr, Outputable bdee, Ord bdee)
536 => Outputable (GenStgRhs bndr bdee) where
537 ppr sty rhs = pprStgRhs sty rhs
541 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
543 pprStgArg sty (StgVarArg var) = ppr sty var
544 pprStgArg sty (StgConArg con) = ppr sty con
545 pprStgArg sty (StgLitArg lit) = ppr sty lit
549 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
550 PprStyle -> GenStgExpr bndr bdee -> Pretty
552 pprStgExpr sty (StgApp func [] lvs)
553 = ppBeside (ppr sty func) (pprStgLVs sty lvs)
556 pprStgExpr sty (StgApp func args lvs)
557 = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
558 4 (ppSep (map (ppr sty) args))
562 pprStgExpr sty (StgCon con args lvs)
563 = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
564 ppPStr SLIT("! ["), interppSP sty args, ppChar ']' ]
566 pprStgExpr sty (StgPrim op args lvs)
567 = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
568 ppPStr SLIT(" ["), interppSP sty args, ppChar ']' ]
572 -- special case: let v = <very specific thing>
578 -- Very special! Suspicious! (SLPJ)
580 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
583 (ppHang (ppBesides [ppPStr SLIT("let { "), ppr sty bndr, ppPStr SLIT(" = "),
584 ppStr (showCostCentre sty True{-as string-} cc),
585 pp_binder_info sty bi,
586 ppPStr SLIT(" ["), ifPprDebug sty (interppSP sty free_vars), ppPStr SLIT("] \\"),
587 ppr sty upd_flag, ppPStr SLIT(" ["),
588 interppSP sty args, ppChar ']'])
589 8 (ppSep [ppCat [ppr sty rhs, ppPStr SLIT("} in")]]))
592 -- special case: let ... in let ...
594 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
596 (ppSep [ppHang (ppPStr SLIT("let {")) 2 (ppCat [pprStgBinding sty bind, ppPStr SLIT("} in")])])
600 pprStgExpr sty (StgLet bind expr)
601 = ppSep [ppHang (ppPStr SLIT("let {")) 2 (pprStgBinding sty bind),
602 ppHang (ppPStr SLIT("} in ")) 2 (ppr sty expr)]
604 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
605 = ppSep [ppHang (ppPStr SLIT("let-no-escape {"))
606 2 (pprStgBinding sty bind),
607 ppHang (ppBeside (ppPStr SLIT("} in "))
610 ppBesides [ppPStr SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole),
611 ppPStr SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss),
617 pprStgExpr sty (StgSCC ty cc expr)
618 = ppSep [ ppCat [ppPStr SLIT("_scc_"), ppStr (showCostCentre sty True{-as string-} cc)],
619 pprStgExpr sty expr ]
623 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
624 = ppSep [ppSep [ppPStr SLIT("case"),
625 ppNest 4 (ppCat [pprStgExpr sty expr,
626 ifPprDebug sty (ppBeside (ppPStr SLIT("::")) (pp_ty alts))]),
627 ppPStr SLIT("of {")],
630 ppBesides [ppPStr SLIT("-- lvs: ["), interppSP sty (uniqSetToList lvs_whole),
631 ppPStr SLIT("]; rhs lvs: ["), interppSP sty (uniqSetToList lvs_rhss),
632 ppPStr SLIT("]; uniq: "), pprUnique uniq])),
633 ppNest 2 (ppr_alts sty alts),
636 ppr_default sty StgNoDefault = ppNil
637 ppr_default sty (StgBindDefault bndr used expr)
638 = ppHang (ppCat [pp_binder, ppPStr SLIT("->")]) 4 (ppr sty expr)
640 pp_binder = if used then ppr sty bndr else ppChar '_'
642 pp_ty (StgAlgAlts ty _ _) = ppr sty ty
643 pp_ty (StgPrimAlts ty _ _) = ppr sty ty
645 ppr_alts sty (StgAlgAlts ty alts deflt)
646 = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
647 ppr_default sty deflt ]
649 ppr_bxd_alt sty (con, params, use_mask, expr)
650 = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppPStr SLIT("->")])
651 4 (ppBeside (ppr sty expr) ppSemi)
653 ppr_alts sty (StgPrimAlts ty alts deflt)
654 = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
655 ppr_default sty deflt ]
657 ppr_ubxd_alt sty (lit, expr)
658 = ppHang (ppCat [ppr sty lit, ppPStr SLIT("->")])
659 4 (ppBeside (ppr sty expr) ppSemi)
663 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
665 pprStgLVs PprForUser lvs = ppNil
668 = if isEmptyUniqSet lvs then
671 ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
675 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
676 PprStyle -> GenStgRhs bndr bdee -> Pretty
679 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
680 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
681 pp_binder_info sty bi,
682 ppPStr SLIT(" ["), ifPprDebug sty (ppr sty free_var),
683 ppPStr SLIT("] \\"), ppr sty upd_flag, ppPStr SLIT(" [] "), ppr sty func ]
685 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
686 = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
687 pp_binder_info sty bi,
688 ppPStr SLIT(" ["), ifPprDebug sty (interppSP sty free_vars),
689 ppPStr SLIT("] \\"), ppr sty upd_flag, ppPStr SLIT(" ["), interppSP sty args, ppChar ']'])
692 pprStgRhs sty (StgRhsCon cc con args)
693 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
694 ppSP, ppr sty con, ppPStr SLIT("! ["), interppSP sty args, ppChar ']' ]
697 pp_binder_info PprForUser _ = ppNil
699 pp_binder_info sty NoStgBinderInfo = ppNil
701 -- cases so boring that we print nothing
702 pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
705 pp_binder_info sty (StgBinderInfo a b c d e)
706 = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
708 pp_bool x = ppr (panic "pp_bool") x
711 Collect @IdInfo@ stuff that is most easily just snaffled straight
712 from the STG bindings.
715 stgArity :: StgRhs -> Int
717 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
718 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args