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)]
75 | StgCoerceBinding bndr occ
78 %************************************************************************
80 \subsection{@GenStgArg@}
82 %************************************************************************
91 getArgPrimRep (StgVarArg local) = idPrimRep local
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 collectExportedStgBinders
482 :: [StgBinding] -- input program
483 -> [Id] -- exported top-level Ids
485 collectExportedStgBinders binds
490 ex es ((StgNonRec b _) : binds)
491 = if not (isExported b) then
496 ex es ((StgRec []) : binds) = ex es binds
498 ex es ((StgRec ((b, rhs) : pairs)) : binds)
499 = ex es (StgNonRec b rhs : (StgRec pairs : binds))
500 -- OK, a total hack; laziness rules
503 %************************************************************************
505 \subsection[Stg-pretty-printing]{Pretty-printing}
507 %************************************************************************
509 Robin Popplestone asked for semi-colon separators on STG binds; here's
510 hoping he likes terminators instead... Ditto for case alternatives.
513 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
514 PprStyle -> GenStgBinding bndr bdee -> Pretty
516 pprStgBinding sty (StgNonRec bndr rhs)
517 = ppHang (ppCat [ppr sty bndr, ppEquals])
518 4 (ppBeside (ppr sty rhs) ppSemi)
520 pprStgBinding sty (StgCoerceBinding bndr occ)
521 = ppHang (ppCat [ppr sty bndr, ppEquals, ppStr "{-Coerce-}"])
522 4 (ppBeside (ppr sty occ) ppSemi)
524 pprStgBinding sty (StgRec pairs)
525 = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
526 (map (ppr_bind sty) pairs))
528 ppr_bind sty (bndr, expr)
529 = ppHang (ppCat [ppr sty bndr, ppEquals])
530 4 (ppBeside (ppr sty expr) ppSemi)
532 pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
533 pprPlainStgBinding sty b = pprStgBinding sty b
537 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
540 instance (Outputable bndr, Outputable bdee, Ord bdee)
541 => Outputable (GenStgBinding bndr bdee) where
544 instance (Outputable bndr, Outputable bdee, Ord bdee)
545 => Outputable (GenStgExpr bndr bdee) where
548 instance (Outputable bndr, Outputable bdee, Ord bdee)
549 => Outputable (GenStgRhs bndr bdee) where
550 ppr sty rhs = pprStgRhs sty rhs
554 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
556 pprStgArg sty (StgVarArg var) = ppr sty var
557 pprStgArg sty (StgLitArg lit) = ppr sty lit
561 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
562 PprStyle -> GenStgExpr bndr bdee -> Pretty
564 pprStgExpr sty (StgApp func [] lvs)
565 = ppBeside (ppr sty func) (pprStgLVs sty lvs)
568 pprStgExpr sty (StgApp func args lvs)
569 = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
570 4 (ppSep (map (ppr sty) args))
574 pprStgExpr sty (StgCon con args lvs)
575 = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
576 ppStr "! [", interppSP sty args, ppStr "]" ]
578 pprStgExpr sty (StgPrim op args lvs)
579 = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
580 ppStr " [", interppSP sty args, ppStr "]" ]
584 -- special case: let v = <very specific thing>
590 -- Very special! Suspicious! (SLPJ)
592 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
595 (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
596 ppStr (showCostCentre sty True{-as string-} cc),
597 pp_binder_info sty bi,
598 ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
599 ppr sty upd_flag, ppStr " [",
600 interppSP sty args, ppStr "]"])
601 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
604 -- special case: let ... in let ...
606 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
608 (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
612 pprStgExpr sty (StgLet bind expr)
613 = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
614 ppHang (ppStr "} in ") 2 (ppr sty expr)]
616 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
617 = ppSep [ppHang (ppStr "let-no-escape {")
618 2 (pprStgBinding sty bind),
619 ppHang (ppBeside (ppStr "} in ")
622 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
623 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
629 pprStgExpr sty (StgSCC ty cc expr)
630 = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
631 pprStgExpr sty expr ]
635 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
636 = ppSep [ppSep [ppStr "case",
637 ppNest 4 (ppCat [pprStgExpr sty expr,
638 ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
642 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
643 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
644 ppStr "]; uniq: ", pprUnique uniq])),
645 ppNest 2 (ppr_alts sty alts),
648 pp_ty (StgAlgAlts ty _ _) = ppr sty ty
649 pp_ty (StgPrimAlts ty _ _) = ppr sty ty
651 ppr_alts sty (StgAlgAlts ty alts deflt)
652 = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
653 ppr_default sty deflt ]
655 ppr_bxd_alt sty (con, params, use_mask, expr)
656 = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
657 4 (ppBeside (ppr sty expr) ppSemi)
661 then ppBesides [ppLparen, ppr sty con, ppRparen]
664 ppr_alts sty (StgPrimAlts ty alts deflt)
665 = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
666 ppr_default sty deflt ]
668 ppr_ubxd_alt sty (lit, expr)
669 = ppHang (ppCat [ppr sty lit, ppStr "->"])
670 4 (ppBeside (ppr sty expr) ppSemi)
672 ppr_default sty StgNoDefault = ppNil
673 ppr_default sty (StgBindDefault bndr used expr)
674 = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
676 pp_binder = if used then ppr sty bndr else ppChar '_'
680 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
682 pprStgLVs PprForUser lvs = ppNil
685 = if isEmptyUniqSet lvs then
688 ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
692 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
693 PprStyle -> GenStgRhs bndr bdee -> Pretty
696 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
697 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
698 pp_binder_info sty bi,
699 ppStr " [", ifPprDebug sty (ppr sty free_var),
700 ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
702 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
703 = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
704 pp_binder_info sty bi,
705 ppStr " [", ifPprDebug sty (interppSP sty free_vars),
706 ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
709 pprStgRhs sty (StgRhsCon cc con args)
710 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
711 ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ]
714 pp_binder_info PprForUser _ = ppNil
716 pp_binder_info sty NoStgBinderInfo = ppNil
718 -- cases so boring that we print nothing
719 pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
722 pp_binder_info sty (StgBinderInfo a b c d e)
723 = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
725 pp_bool x = ppr (panic "pp_bool") x
728 Collect @IdInfo@ stuff that is most easily just snaffled straight
729 from the STG bindings.
732 stgArity :: StgRhs -> Int
734 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
735 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args