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...
44 import CostCentre ( showCostCentre )
45 import Id ( idPrimRep, GenId{-instance NamedThing-} )
46 import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
47 import Name ( isExported, isSymLexeme )
48 import Outputable ( ifPprDebug, interppSP, interpp'SP,
49 Outputable(..){-instance * Bool-}
51 import PprStyle ( PprStyle(..) )
52 import PprType ( GenType{-instance Outputable-} )
53 import Pretty -- all of it
54 import PrimOp ( PrimOp{-instance Outputable-} )
55 import Unique ( pprUnique )
56 import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet(..) )
60 %************************************************************************
62 \subsection{@GenStgBinding@}
64 %************************************************************************
66 As usual, expressions are interesting; other things are boring. Here
67 are the boring things [except note the @GenStgRhs@], parameterised
68 with respect to binder and occurrence information (just as in
72 data GenStgBinding bndr occ
73 = StgNonRec bndr (GenStgRhs bndr occ)
74 | StgRec [(bndr, GenStgRhs bndr occ)]
77 %************************************************************************
79 \subsection{@GenStgArg@}
81 %************************************************************************
90 getArgPrimRep (StgVarArg local) = idPrimRep local
91 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
93 isLitLitArg (StgLitArg x) = isLitLitLit x
97 %************************************************************************
99 \subsection{STG expressions}
101 %************************************************************************
103 The @GenStgExpr@ data type is parameterised on binder and occurrence
106 %************************************************************************
108 \subsubsection{@GenStgExpr@ application}
110 %************************************************************************
112 An application is of a function to a list of atoms [not expressions].
113 Operationally, we want to push the arguments on the stack and call the
114 function. (If the arguments were expressions, we would have to build
115 their closures first.)
117 There is no constructor for a lone variable; it would appear as
120 type GenStgLiveVars occ = UniqSet occ
122 data GenStgExpr bndr occ
124 (GenStgArg occ) -- function
125 [GenStgArg occ] -- arguments
126 (GenStgLiveVars occ) -- Live vars in continuation; ie not
127 -- including the function and args
129 -- NB: a literal is: StgApp <lit-atom> [] ...
132 %************************************************************************
134 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
136 %************************************************************************
138 There are two specialised forms of application, for
139 constructors and primitives.
141 | StgCon -- always saturated
142 Id -- data constructor
144 (GenStgLiveVars occ) -- Live vars in continuation; ie not
145 -- including the constr and args
147 | StgPrim -- always saturated
150 (GenStgLiveVars occ) -- Live vars in continuation; ie not
151 -- including the op and args
153 These forms are to do ``inline versions,'' as it were.
154 An example might be: @f x = x:[]@.
156 %************************************************************************
158 \subsubsection{@GenStgExpr@: case-expressions}
160 %************************************************************************
162 This has the same boxed/unboxed business as Core case expressions.
165 (GenStgExpr bndr occ)
166 -- the thing to examine
168 (GenStgLiveVars occ) -- Live vars of whole case
169 -- expression; i.e., those which mustn't be
172 (GenStgLiveVars occ) -- Live vars of RHSs;
173 -- i.e., those which must be saved before eval.
175 -- note that an alt's constructor's
176 -- binder-variables are NOT counted in the
177 -- free vars for the alt's RHS
179 Unique -- Occasionally needed to compile case
180 -- statements, as the uniq for a local
181 -- variable to hold the tag of a primop with
184 (GenStgCaseAlts bndr occ)
187 %************************************************************************
189 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
191 %************************************************************************
193 The various forms of let(rec)-expression encode most of the
194 interesting things we want to do.
198 let-closure x = [free-vars] expr [args]
203 let x = (\free-vars -> \args -> expr) free-vars
205 \tr{args} may be empty (and is for most closures). It isn't under
206 circumstances like this:
212 let-closure x = [z] [y] (y+z)
214 The idea is that we compile code for @(y+z)@ in an environment in which
215 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
216 offset from the stack pointer.
218 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
222 let-constructor x = Constructor [args]
226 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
229 Letrec-expressions are essentially the same deal as
230 let-closure/let-constructor, so we use a common structure and
231 distinguish between them with an @is_recursive@ boolean flag.
235 let-unboxed u = an arbitrary arithmetic expression in unboxed values
238 All the stuff on the RHS must be fully evaluated. No function calls either!
240 (We've backed away from this toward case-expressions with
241 suitably-magical alts ...)
244 ~[Advanced stuff here! Not to start with, but makes pattern matching
245 generate more efficient code.]
248 let-escapes-not fail = expr
251 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
252 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
253 Rather than build a closure for @fail@, all we need do is to record the stack
254 level at the moment of the @let-escapes-not@; then entering @fail@ is just
255 a matter of adjusting the stack pointer back down to that point and entering
260 f x y = let z = huge-expression in
266 (A let-escapes-not is an @StgLetNoEscape@.)
269 We may eventually want:
271 let-literal x = Literal
275 (ToDo: is this obsolete?)
278 And so the code for let(rec)-things:
281 (GenStgBinding bndr occ) -- right hand sides (see below)
282 (GenStgExpr bndr occ) -- body
284 | StgLetNoEscape -- remember: ``advanced stuff''
285 (GenStgLiveVars occ) -- Live in the whole let-expression
286 -- Mustn't overwrite these stack slots
287 -- *Doesn't* include binders of the let(rec).
289 (GenStgLiveVars occ) -- Live in the right hand sides (only)
290 -- These are the ones which must be saved on
291 -- the stack if they aren't there already
292 -- *Does* include binders of the let(rec) if recursive.
294 (GenStgBinding bndr occ) -- right hand sides (see below)
295 (GenStgExpr bndr occ) -- body
298 %************************************************************************
300 \subsubsection{@GenStgExpr@: @scc@ expressions}
302 %************************************************************************
304 Finally for @scc@ expressions we introduce a new STG construct.
308 Type -- the type of the body
309 CostCentre -- label of SCC expression
310 (GenStgExpr bndr occ) -- scc expression
314 %************************************************************************
316 \subsection{STG right-hand sides}
318 %************************************************************************
320 Here's the rest of the interesting stuff for @StgLet@s; the first
321 flavour is for closures:
323 data GenStgRhs bndr occ
325 CostCentre -- cost centre to be attached (default is CCC)
326 StgBinderInfo -- Info about how this binder is used (see below)
327 [occ] -- non-global free vars; a list, rather than
328 -- a set, because order is important
329 UpdateFlag -- ReEntrant | Updatable | SingleEntry
330 [bndr] -- arguments; if empty, then not a function;
331 -- as above, order is important
332 (GenStgExpr bndr occ) -- body
334 An example may be in order. Consider:
336 let t = \x -> \y -> ... x ... y ... p ... q in e
338 Pulling out the free vars and stylising somewhat, we get the equivalent:
340 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
342 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
343 offsets from @Node@ into the closure, and the code ptr for the closure
344 will be exactly that in parentheses above.
346 The second flavour of right-hand-side is for constructors (simple but important):
349 CostCentre -- Cost centre to be attached (default is CCC).
350 -- Top-level (static) ones will end up with
351 -- DontCareCC, because we don't count static
352 -- data in heap profiles, and we don't set CCC
353 -- from static closure.
355 [GenStgArg occ] -- args
358 Here's the @StgBinderInfo@ type, and its combining op:
363 Bool -- At least one occurrence as an argument
365 Bool -- At least one occurrence in an unsaturated application
367 Bool -- This thing (f) has at least occurrence of the form:
368 -- x = [..] \u [] -> f a b c
369 -- where the application is saturated
371 Bool -- Ditto for non-updatable x.
373 Bool -- At least one fake application occurrence, that is
374 -- an StgApp f args where args is an empty list
375 -- This is due to the fact that we do not have a
376 -- StgVar constructor.
377 -- Used by the lambda lifter.
378 -- True => "at least one unsat app" is True too
380 stgArgOcc = StgBinderInfo True False False False False
381 stgUnsatOcc = StgBinderInfo False True False False False
382 stgStdHeapOcc = StgBinderInfo False False True False False
383 stgNoUpdHeapOcc = StgBinderInfo False False False True False
384 stgNormalOcc = StgBinderInfo False False False False False
385 -- [Andre] can't think of a good name for the last one.
386 stgFakeFunAppOcc = StgBinderInfo False True False False True
388 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
390 combineStgBinderInfo NoStgBinderInfo info2 = info2
391 combineStgBinderInfo info1 NoStgBinderInfo = info1
392 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
393 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
394 = StgBinderInfo (arg1 || arg2)
396 (std_heap1 || std_heap2)
397 (upd_heap1 || upd_heap2)
401 %************************************************************************
403 \subsection[Stg-case-alternatives]{STG case alternatives}
405 %************************************************************************
407 Just like in @CoreSyntax@ (except no type-world stuff).
410 data GenStgCaseAlts bndr occ
411 = StgAlgAlts Type -- so we can find out things about constructor family
412 [(Id, -- alts: data constructor,
413 [bndr], -- constructor's parameters,
414 [Bool], -- "use mask", same length as
415 -- parameters; a True in a
416 -- param's position if it is
418 GenStgExpr bndr occ)] -- ...right-hand side.
419 (GenStgCaseDefault bndr occ)
420 | StgPrimAlts Type -- so we can find out things about constructor family
421 [(Literal, -- alts: unboxed literal,
422 GenStgExpr bndr occ)] -- rhs.
423 (GenStgCaseDefault bndr occ)
425 data GenStgCaseDefault bndr occ
426 = StgNoDefault -- small con family: all
427 -- constructor accounted for
428 | StgBindDefault bndr -- form: var -> expr
429 Bool -- True <=> var is used in rhs
430 -- i.e., False <=> "_ -> expr"
431 (GenStgExpr bndr occ)
434 %************************************************************************
436 \subsection[Stg]{The Plain STG parameterisation}
438 %************************************************************************
440 This happens to be the only one we use at the moment.
443 type StgBinding = GenStgBinding Id Id
444 type StgArg = GenStgArg Id
445 type StgLiveVars = GenStgLiveVars Id
446 type StgExpr = GenStgExpr Id Id
447 type StgRhs = GenStgRhs Id Id
448 type StgCaseAlts = GenStgCaseAlts Id Id
449 type StgCaseDefault = GenStgCaseDefault Id Id
452 %************************************************************************
454 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
456 %************************************************************************
458 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
461 data UpdateFlag = ReEntrant | Updatable | SingleEntry
463 instance Outputable UpdateFlag where
465 = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
468 %************************************************************************
470 \subsection[Stg-utility-functions]{Utility functions}
472 %************************************************************************
475 For doing interfaces, we want the exported top-level Ids from the
476 final pre-codegen STG code, so as to be sure we have the
477 latest/greatest pragma info.
480 collectExportedStgBinders
481 :: [StgBinding] -- input program
482 -> [Id] -- exported top-level Ids
484 collectExportedStgBinders binds
489 ex es ((StgNonRec b _) : binds)
490 = if not (isExported b) then
495 ex es ((StgRec []) : binds) = ex es binds
497 ex es ((StgRec ((b, rhs) : pairs)) : binds)
498 = ex es (StgNonRec b rhs : (StgRec pairs : binds))
499 -- OK, a total hack; laziness rules
502 %************************************************************************
504 \subsection[Stg-pretty-printing]{Pretty-printing}
506 %************************************************************************
508 Robin Popplestone asked for semi-colon separators on STG binds; here's
509 hoping he likes terminators instead... Ditto for case alternatives.
512 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
513 PprStyle -> GenStgBinding bndr bdee -> Pretty
515 pprStgBinding sty (StgNonRec bndr rhs)
516 = ppHang (ppCat [ppr sty bndr, ppEquals])
517 4 (ppBeside (ppr sty rhs) ppSemi)
519 pprStgBinding sty (StgRec pairs)
520 = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
521 (map (ppr_bind sty) pairs))
523 ppr_bind sty (bndr, expr)
524 = ppHang (ppCat [ppr sty bndr, ppEquals])
525 4 (ppBeside (ppr sty expr) ppSemi)
527 pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
528 pprPlainStgBinding sty b = pprStgBinding sty b
532 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
535 instance (Outputable bndr, Outputable bdee, Ord bdee)
536 => Outputable (GenStgBinding bndr bdee) where
539 instance (Outputable bndr, Outputable bdee, Ord bdee)
540 => Outputable (GenStgExpr bndr bdee) where
543 instance (Outputable bndr, Outputable bdee, Ord bdee)
544 => Outputable (GenStgRhs bndr bdee) where
545 ppr sty rhs = pprStgRhs sty rhs
549 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
551 pprStgArg sty (StgVarArg var) = ppr sty var
552 pprStgArg sty (StgLitArg lit) = ppr sty lit
556 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
557 PprStyle -> GenStgExpr bndr bdee -> Pretty
559 pprStgExpr sty (StgApp func [] lvs)
560 = ppBeside (ppr sty func) (pprStgLVs sty lvs)
563 pprStgExpr sty (StgApp func args lvs)
564 = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
565 4 (ppSep (map (ppr sty) args))
569 pprStgExpr sty (StgCon con args lvs)
570 = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
571 ppStr "! [", interppSP sty args, ppStr "]" ]
573 pprStgExpr sty (StgPrim op args lvs)
574 = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
575 ppStr " [", interppSP sty args, ppStr "]" ]
579 -- special case: let v = <very specific thing>
585 -- Very special! Suspicious! (SLPJ)
587 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
590 (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
591 ppStr (showCostCentre sty True{-as string-} cc),
592 pp_binder_info sty bi,
593 ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
594 ppr sty upd_flag, ppStr " [",
595 interppSP sty args, ppStr "]"])
596 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
599 -- special case: let ... in let ...
601 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
603 (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
607 pprStgExpr sty (StgLet bind expr)
608 = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
609 ppHang (ppStr "} in ") 2 (ppr sty expr)]
611 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
612 = ppSep [ppHang (ppStr "let-no-escape {")
613 2 (pprStgBinding sty bind),
614 ppHang (ppBeside (ppStr "} in ")
617 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
618 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
624 pprStgExpr sty (StgSCC ty cc expr)
625 = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
626 pprStgExpr sty expr ]
630 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
631 = ppSep [ppSep [ppStr "case",
632 ppNest 4 (ppCat [pprStgExpr sty expr,
633 ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
637 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
638 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
639 ppStr "]; uniq: ", pprUnique uniq])),
640 ppNest 2 (ppr_alts sty alts),
643 pp_ty (StgAlgAlts ty _ _) = ppr sty ty
644 pp_ty (StgPrimAlts ty _ _) = ppr sty ty
646 ppr_alts sty (StgAlgAlts ty alts deflt)
647 = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
648 ppr_default sty deflt ]
650 ppr_bxd_alt sty (con, params, use_mask, expr)
651 = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
652 4 (ppBeside (ppr sty expr) ppSemi)
656 then ppBesides [ppLparen, ppr sty con, ppRparen]
659 ppr_alts sty (StgPrimAlts ty alts deflt)
660 = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
661 ppr_default sty deflt ]
663 ppr_ubxd_alt sty (lit, expr)
664 = ppHang (ppCat [ppr sty lit, ppStr "->"])
665 4 (ppBeside (ppr sty expr) ppSemi)
667 ppr_default sty StgNoDefault = ppNil
668 ppr_default sty (StgBindDefault bndr used expr)
669 = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
671 pp_binder = if used then ppr sty bndr else ppChar '_'
675 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
677 pprStgLVs PprForUser lvs = ppNil
680 = if isEmptyUniqSet lvs then
683 ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
687 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
688 PprStyle -> GenStgRhs bndr bdee -> Pretty
691 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
692 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
693 pp_binder_info sty bi,
694 ppStr " [", ifPprDebug sty (ppr sty free_var),
695 ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
697 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
698 = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
699 pp_binder_info sty bi,
700 ppStr " [", ifPprDebug sty (interppSP sty free_vars),
701 ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
704 pprStgRhs sty (StgRhsCon cc con args)
705 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
706 ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ]
709 pp_binder_info PprForUser _ = ppNil
711 pp_binder_info sty NoStgBinderInfo = ppNil
713 -- cases so boring that we print nothing
714 pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
717 pp_binder_info sty (StgBinderInfo a b c d e)
718 = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
720 pp_bool x = ppr (panic "pp_bool") x
723 Collect @IdInfo@ stuff that is most easily just snaffled straight
724 from the STG bindings.
727 stgArity :: StgRhs -> Int
729 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
730 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args