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"
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 StgArg(..), StgLiveVars(..),
30 StgBinding(..), StgExpr(..), StgRhs(..),
31 StgCaseAlts(..), StgCaseDefault(..),
37 collectExportedStgBinders
39 -- and to make the interface self-sufficient...
45 import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..),
47 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
48 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
50 import HsSyn ( HsBinds, HsExpr, GRHS, GRHSsAndBinds, InPat )
52 import Literal ( literalPrimRep, isLitLitLit,
53 Literal(..) -- (..) for pragmas
55 import Id ( idType, getIdPrimRep, toplevelishId,
56 isTopLevId, Id, IdInfo
58 import Maybes ( Maybe(..), catMaybes )
61 import CostCentre ( showCostCentre, CostCentre )
67 %************************************************************************
69 \subsection{@GenStgBinding@}
71 %************************************************************************
73 As usual, expressions are interesting; other things are boring. Here
74 are the boring things [except note the @GenStgRhs@], parameterised
75 with respect to binder and occurrence information (just as in
79 data GenStgBinding bndr occ
80 = StgNonRec bndr (GenStgRhs bndr occ)
81 | StgRec [(bndr, GenStgRhs bndr occ)]
84 %************************************************************************
86 \subsection{@GenStgArg@}
88 %************************************************************************
97 getArgPrimRep (StgVarArg local) = getIdPrimRep local
98 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
100 isLitLitArg (StgLitArg x) = isLitLitLit x
101 isLitLitArg _ = False
104 %************************************************************************
106 \subsection{STG expressions}
108 %************************************************************************
110 The @GenStgExpr@ data type is parameterised on binder and occurrence
113 %************************************************************************
115 \subsubsection{@GenStgExpr@ application}
117 %************************************************************************
119 An application is of a function to a list of atoms [not expressions].
120 Operationally, we want to push the arguments on the stack and call the
121 function. (If the arguments were expressions, we would have to build
122 their closures first.)
124 There is no constructor for a lone variable; it would appear as
127 type GenStgLiveVars occ = UniqSet occ
129 data GenStgExpr bndr occ
131 (GenStgArg occ) -- function
132 [GenStgArg occ] -- arguments
133 (GenStgLiveVars occ) -- Live vars in continuation; ie not
134 -- including the function and args
136 -- NB: a literal is: StgApp <lit-atom> [] ...
139 %************************************************************************
141 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
143 %************************************************************************
145 There are two specialised forms of application, for
146 constructors and primitives.
148 | StgCon -- always saturated
149 Id -- data constructor
151 (GenStgLiveVars occ) -- Live vars in continuation; ie not
152 -- including the constr and args
154 | StgPrim -- always saturated
157 (GenStgLiveVars occ) -- Live vars in continuation; ie not
158 -- including the op and args
160 These forms are to do ``inline versions,'' as it were.
161 An example might be: @f x = x:[]@.
163 %************************************************************************
165 \subsubsection{@GenStgExpr@: case-expressions}
167 %************************************************************************
169 This has the same boxed/unboxed business as Core case expressions.
172 (GenStgExpr bndr occ)
173 -- the thing to examine
175 (GenStgLiveVars occ) -- Live vars of whole case
176 -- expression; i.e., those which mustn't be
179 (GenStgLiveVars occ) -- Live vars of RHSs;
180 -- i.e., those which must be saved before eval.
182 -- note that an alt's constructor's
183 -- binder-variables are NOT counted in the
184 -- free vars for the alt's RHS
186 Unique -- Occasionally needed to compile case
187 -- statements, as the uniq for a local
188 -- variable to hold the tag of a primop with
191 (GenStgCaseAlts bndr occ)
194 %************************************************************************
196 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
198 %************************************************************************
200 The various forms of let(rec)-expression encode most of the
201 interesting things we want to do.
205 let-closure x = [free-vars] expr [args]
210 let x = (\free-vars -> \args -> expr) free-vars
212 \tr{args} may be empty (and is for most closures). It isn't under
213 circumstances like this:
219 let-closure x = [z] [y] (y+z)
221 The idea is that we compile code for @(y+z)@ in an environment in which
222 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
223 offset from the stack pointer.
225 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
229 let-constructor x = Constructor [args]
233 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
236 Letrec-expressions are essentially the same deal as
237 let-closure/let-constructor, so we use a common structure and
238 distinguish between them with an @is_recursive@ boolean flag.
242 let-unboxed u = an arbitrary arithmetic expression in unboxed values
245 All the stuff on the RHS must be fully evaluated. No function calls either!
247 (We've backed away from this toward case-expressions with
248 suitably-magical alts ...)
251 ~[Advanced stuff here! Not to start with, but makes pattern matching
252 generate more efficient code.]
255 let-escapes-not fail = expr
258 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
259 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
260 Rather than build a closure for @fail@, all we need do is to record the stack
261 level at the moment of the @let-escapes-not@; then entering @fail@ is just
262 a matter of adjusting the stack pointer back down to that point and entering
267 f x y = let z = huge-expression in
273 (A let-escapes-not is an @StgLetNoEscape@.)
276 We may eventually want:
278 let-literal x = Literal
282 (ToDo: is this obsolete?)
285 And so the code for let(rec)-things:
288 (GenStgBinding bndr occ) -- right hand sides (see below)
289 (GenStgExpr bndr occ) -- body
291 | StgLetNoEscape -- remember: ``advanced stuff''
292 (GenStgLiveVars occ) -- Live in the whole let-expression
293 -- Mustn't overwrite these stack slots
294 -- *Doesn't* include binders of the let(rec).
296 (GenStgLiveVars occ) -- Live in the right hand sides (only)
297 -- These are the ones which must be saved on
298 -- the stack if they aren't there already
299 -- *Does* include binders of the let(rec) if recursive.
301 (GenStgBinding bndr occ) -- right hand sides (see below)
302 (GenStgExpr bndr occ) -- body
305 %************************************************************************
307 \subsubsection{@GenStgExpr@: @scc@ expressions}
309 %************************************************************************
311 Finally for @scc@ expressions we introduce a new STG construct.
315 Type -- the type of the body
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 CostCentre -- cost centre to be attached (default is CCC)
333 StgBinderInfo -- Info about how this binder is used (see below)
334 [occ] -- non-global free vars; a list, rather than
335 -- a set, because order is important
336 UpdateFlag -- ReEntrant | Updatable | SingleEntry
337 [bndr] -- arguments; if empty, then not a function;
338 -- as above, order is important
339 (GenStgExpr bndr occ) -- body
341 An example may be in order. Consider:
343 let t = \x -> \y -> ... x ... y ... p ... q in e
345 Pulling out the free vars and stylising somewhat, we get the equivalent:
347 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
349 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
350 offsets from @Node@ into the closure, and the code ptr for the closure
351 will be exactly that in parentheses above.
353 The second flavour of right-hand-side is for constructors (simple but important):
356 CostCentre -- Cost centre to be attached (default is CCC).
357 -- Top-level (static) ones will end up with
358 -- DontCareCC, because we don't count static
359 -- data in heap profiles, and we don't set CCC
360 -- from static closure.
362 [GenStgArg occ] -- args
365 Here's the @StgBinderInfo@ type, and its combining op:
370 Bool -- At least one occurrence as an argument
372 Bool -- At least one occurrence in an unsaturated application
374 Bool -- This thing (f) has at least occurrence of the form:
375 -- x = [..] \u [] -> f a b c
376 -- where the application is saturated
378 Bool -- Ditto for non-updatable x.
380 Bool -- At least one fake application occurrence, that is
381 -- an StgApp f args where args is an empty list
382 -- This is due to the fact that we do not have a
383 -- StgVar constructor.
384 -- Used by the lambda lifter.
385 -- True => "at least one unsat app" is True too
387 stgArgOcc = StgBinderInfo True False False False False
388 stgUnsatOcc = StgBinderInfo False True False False False
389 stgStdHeapOcc = StgBinderInfo False False True False False
390 stgNoUpdHeapOcc = StgBinderInfo False False False True False
391 stgNormalOcc = StgBinderInfo False False False False False
392 -- [Andre] can't think of a good name for the last one.
393 stgFakeFunAppOcc = StgBinderInfo False True False False True
395 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
397 combineStgBinderInfo NoStgBinderInfo info2 = info2
398 combineStgBinderInfo info1 NoStgBinderInfo = info1
399 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
400 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
401 = StgBinderInfo (arg1 || arg2)
403 (std_heap1 || std_heap2)
404 (upd_heap1 || upd_heap2)
408 %************************************************************************
410 \subsection[Stg-case-alternatives]{STG case alternatives}
412 %************************************************************************
414 Just like in @CoreSyntax@ (except no type-world stuff).
417 data GenStgCaseAlts bndr occ
418 = StgAlgAlts Type -- so we can find out things about constructor family
419 [(Id, -- alts: data constructor,
420 [bndr], -- constructor's parameters,
421 [Bool], -- "use mask", same length as
422 -- parameters; a True in a
423 -- param's position if it is
425 GenStgExpr bndr occ)] -- ...right-hand side.
426 (GenStgCaseDefault bndr occ)
427 | StgPrimAlts Type -- so we can find out things about constructor family
428 [(Literal, -- alts: unboxed literal,
429 GenStgExpr bndr occ)] -- rhs.
430 (GenStgCaseDefault bndr occ)
432 data GenStgCaseDefault bndr occ
433 = StgNoDefault -- small con family: all
434 -- constructor accounted for
435 | StgBindDefault bndr -- form: var -> expr
436 Bool -- True <=> var is used in rhs
437 -- i.e., False <=> "_ -> expr"
438 (GenStgExpr bndr occ)
441 %************************************************************************
443 \subsection[Stg]{The Plain STG parameterisation}
445 %************************************************************************
447 This happens to be the only one we use at the moment.
450 type StgBinding = GenStgBinding Id Id
451 type StgArg = GenStgArg Id
452 type StgLiveVars = GenStgLiveVars Id
453 type StgExpr = GenStgExpr Id Id
454 type StgRhs = GenStgRhs Id Id
455 type StgCaseAlts = GenStgCaseAlts Id Id
456 type StgCaseDefault = GenStgCaseDefault Id Id
459 %************************************************************************
461 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
463 %************************************************************************
465 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
468 data UpdateFlag = ReEntrant | Updatable | SingleEntry
470 instance Outputable UpdateFlag where
472 = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
475 %************************************************************************
477 \subsection[Stg-utility-functions]{Utility functions}
479 %************************************************************************
482 For doing interfaces, we want the exported top-level Ids from the
483 final pre-codegen STG code, so as to be sure we have the
484 latest/greatest pragma info.
487 collectExportedStgBinders
488 :: [StgBinding] -- input program
489 -> [Id] -- exported top-level Ids
491 collectExportedStgBinders binds
496 ex es ((StgNonRec b _) : binds)
497 = if not (isExported b) then
502 ex es ((StgRec []) : binds) = ex es binds
504 ex es ((StgRec ((b, rhs) : pairs)) : binds)
505 = ex es (StgNonRec b rhs : (StgRec pairs : binds))
506 -- OK, a total hack; laziness rules
509 %************************************************************************
511 \subsection[Stg-pretty-printing]{Pretty-printing}
513 %************************************************************************
515 Robin Popplestone asked for semi-colon separators on STG binds; here's
516 hoping he likes terminators instead... Ditto for case alternatives.
519 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
520 PprStyle -> GenStgBinding bndr bdee -> Pretty
522 pprStgBinding sty (StgNonRec bndr rhs)
523 = ppHang (ppCat [ppr sty bndr, ppEquals])
524 4 (ppBeside (ppr sty rhs) ppSemi)
526 pprStgBinding sty (StgRec pairs)
527 = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
528 (map (ppr_bind sty) pairs))
530 ppr_bind sty (bndr, expr)
531 = ppHang (ppCat [ppr sty bndr, ppEquals])
532 4 (ppBeside (ppr sty expr) ppSemi)
534 pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
535 pprPlainStgBinding sty b = pprStgBinding sty b
539 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
542 instance (Outputable bndr, Outputable bdee, Ord bdee)
543 => Outputable (GenStgBinding bndr bdee) where
546 instance (Outputable bndr, Outputable bdee, Ord bdee)
547 => Outputable (GenStgExpr bndr bdee) where
550 instance (Outputable bndr, Outputable bdee, Ord bdee)
551 => Outputable (GenStgRhs bndr bdee) where
552 ppr sty rhs = pprStgRhs sty rhs
556 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
558 pprStgArg sty (StgVarArg var) = ppr sty var
559 pprStgArg sty (StgLitArg lit) = ppr sty lit
563 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
564 PprStyle -> GenStgExpr bndr bdee -> Pretty
566 pprStgExpr sty (StgApp func [] lvs)
567 = ppBeside (ppr sty func) (pprStgLVs sty lvs)
570 pprStgExpr sty (StgApp func args lvs)
571 = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
572 4 (ppSep (map (ppr sty) args))
576 pprStgExpr sty (StgCon con args lvs)
577 = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
578 ppStr "! [", interppSP sty args, ppStr "]" ]
580 pprStgExpr sty (StgPrim op args lvs)
581 = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
582 ppStr " [", interppSP sty args, ppStr "]" ]
586 -- special case: let v = <very specific thing>
592 -- Very special! Suspicious! (SLPJ)
594 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
597 (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
598 ppStr (showCostCentre sty True{-as string-} cc),
599 pp_binder_info sty bi,
600 ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
601 ppr sty upd_flag, ppStr " [",
602 interppSP sty args, ppStr "]"])
603 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
606 -- special case: let ... in let ...
608 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
610 (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
614 pprStgExpr sty (StgLet bind expr)
615 = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
616 ppHang (ppStr "} in ") 2 (ppr sty expr)]
618 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
619 = ppSep [ppHang (ppStr "let-no-escape {")
620 2 (pprStgBinding sty bind),
621 ppHang (ppBeside (ppStr "} in ")
624 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
625 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
631 pprStgExpr sty (StgSCC ty cc expr)
632 = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
633 pprStgExpr sty expr ]
637 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
638 = ppSep [ppSep [ppStr "case",
639 ppNest 4 (ppCat [pprStgExpr sty expr,
640 ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
644 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
645 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
646 ppStr "]; uniq: ", pprUnique uniq])),
647 ppNest 2 (ppr_alts sty alts),
650 pp_ty (StgAlgAlts ty _ _) = ppr sty ty
651 pp_ty (StgPrimAlts ty _ _) = ppr sty ty
653 ppr_alts sty (StgAlgAlts ty alts deflt)
654 = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
655 ppr_default sty deflt ]
657 ppr_bxd_alt sty (con, params, use_mask, expr)
658 = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
659 4 (ppBeside (ppr sty expr) ppSemi)
663 then ppBesides [ppLparen, ppr sty con, ppRparen]
666 ppr_alts sty (StgPrimAlts ty alts deflt)
667 = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
668 ppr_default sty deflt ]
670 ppr_ubxd_alt sty (lit, expr)
671 = ppHang (ppCat [ppr sty lit, ppStr "->"])
672 4 (ppBeside (ppr sty expr) ppSemi)
674 ppr_default sty StgNoDefault = ppNil
675 ppr_default sty (StgBindDefault bndr used expr)
676 = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
678 pp_binder = if used then ppr sty bndr else ppChar '_'
682 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
684 pprStgLVs PprForUser lvs = ppNil
687 = if isEmptyUniqSet lvs then
690 ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
694 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
695 PprStyle -> GenStgRhs bndr bdee -> Pretty
698 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
699 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
700 pp_binder_info sty bi,
701 ppStr " [", ifPprDebug sty (ppr sty free_var),
702 ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
704 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
705 = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
706 pp_binder_info sty bi,
707 ppStr " [", ifPprDebug sty (interppSP sty free_vars),
708 ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
711 pprStgRhs sty (StgRhsCon cc con args)
712 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
713 ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ]
716 pp_binder_info PprForUser _ = ppNil
718 pp_binder_info sty NoStgBinderInfo = ppNil
720 -- cases so boring that we print nothing
721 pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
724 pp_binder_info sty (StgBinderInfo a b c d e)
725 = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
727 pp_bool x = ppr (panic "pp_bool") x
730 Collect @IdInfo@ stuff that is most easily just snaffled straight
731 from the STG bindings.
734 stgArity :: StgRhs -> Int
736 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
737 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args