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 ( externallyVisibleId, idPrimRep, GenId{-instance NamedThing-} )
44 import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
45 import Name ( isSymLexeme )
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 %************************************************************************
89 getArgPrimRep (StgVarArg local) = idPrimRep local
90 getArgPrimRep (StgLitArg lit) = literalPrimRep lit
92 isLitLitArg (StgLitArg x) = isLitLitLit x
96 %************************************************************************
98 \subsection{STG expressions}
100 %************************************************************************
102 The @GenStgExpr@ data type is parameterised on binder and occurrence
105 %************************************************************************
107 \subsubsection{@GenStgExpr@ application}
109 %************************************************************************
111 An application is of a function to a list of atoms [not expressions].
112 Operationally, we want to push the arguments on the stack and call the
113 function. (If the arguments were expressions, we would have to build
114 their closures first.)
116 There is no constructor for a lone variable; it would appear as
119 type GenStgLiveVars occ = UniqSet occ
121 data GenStgExpr bndr occ
123 (GenStgArg occ) -- function
124 [GenStgArg occ] -- arguments
125 (GenStgLiveVars occ) -- Live vars in continuation; ie not
126 -- including the function and args
128 -- NB: a literal is: StgApp <lit-atom> [] ...
131 %************************************************************************
133 \subsubsection{@StgCon@ and @StgPrim@---saturated applications}
135 %************************************************************************
137 There are two specialised forms of application, for
138 constructors and primitives.
140 | StgCon -- always saturated
141 Id -- data constructor
143 (GenStgLiveVars occ) -- Live vars in continuation; ie not
144 -- including the constr and args
146 | StgPrim -- always saturated
149 (GenStgLiveVars occ) -- Live vars in continuation; ie not
150 -- including the op and args
152 These forms are to do ``inline versions,'' as it were.
153 An example might be: @f x = x:[]@.
155 %************************************************************************
157 \subsubsection{@GenStgExpr@: case-expressions}
159 %************************************************************************
161 This has the same boxed/unboxed business as Core case expressions.
164 (GenStgExpr bndr occ)
165 -- the thing to examine
167 (GenStgLiveVars occ) -- Live vars of whole case
168 -- expression; i.e., those which mustn't be
171 (GenStgLiveVars occ) -- Live vars of RHSs;
172 -- i.e., those which must be saved before eval.
174 -- note that an alt's constructor's
175 -- binder-variables are NOT counted in the
176 -- free vars for the alt's RHS
178 Unique -- Occasionally needed to compile case
179 -- statements, as the uniq for a local
180 -- variable to hold the tag of a primop with
183 (GenStgCaseAlts bndr occ)
186 %************************************************************************
188 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
190 %************************************************************************
192 The various forms of let(rec)-expression encode most of the
193 interesting things we want to do.
197 let-closure x = [free-vars] expr [args]
202 let x = (\free-vars -> \args -> expr) free-vars
204 \tr{args} may be empty (and is for most closures). It isn't under
205 circumstances like this:
211 let-closure x = [z] [y] (y+z)
213 The idea is that we compile code for @(y+z)@ in an environment in which
214 @z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
215 offset from the stack pointer.
217 (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
221 let-constructor x = Constructor [args]
225 (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
228 Letrec-expressions are essentially the same deal as
229 let-closure/let-constructor, so we use a common structure and
230 distinguish between them with an @is_recursive@ boolean flag.
234 let-unboxed u = an arbitrary arithmetic expression in unboxed values
237 All the stuff on the RHS must be fully evaluated. No function calls either!
239 (We've backed away from this toward case-expressions with
240 suitably-magical alts ...)
243 ~[Advanced stuff here! Not to start with, but makes pattern matching
244 generate more efficient code.]
247 let-escapes-not fail = expr
250 Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
251 or pass it to another function. All @e'@ will ever do is tail-call @fail@.
252 Rather than build a closure for @fail@, all we need do is to record the stack
253 level at the moment of the @let-escapes-not@; then entering @fail@ is just
254 a matter of adjusting the stack pointer back down to that point and entering
259 f x y = let z = huge-expression in
265 (A let-escapes-not is an @StgLetNoEscape@.)
268 We may eventually want:
270 let-literal x = Literal
274 (ToDo: is this obsolete?)
277 And so the code for let(rec)-things:
280 (GenStgBinding bndr occ) -- right hand sides (see below)
281 (GenStgExpr bndr occ) -- body
283 | StgLetNoEscape -- remember: ``advanced stuff''
284 (GenStgLiveVars occ) -- Live in the whole let-expression
285 -- Mustn't overwrite these stack slots
286 -- *Doesn't* include binders of the let(rec).
288 (GenStgLiveVars occ) -- Live in the right hand sides (only)
289 -- These are the ones which must be saved on
290 -- the stack if they aren't there already
291 -- *Does* include binders of the let(rec) if recursive.
293 (GenStgBinding bndr occ) -- right hand sides (see below)
294 (GenStgExpr bndr occ) -- body
297 %************************************************************************
299 \subsubsection{@GenStgExpr@: @scc@ expressions}
301 %************************************************************************
303 Finally for @scc@ expressions we introduce a new STG construct.
307 Type -- the type of the body
308 CostCentre -- label of SCC expression
309 (GenStgExpr bndr occ) -- scc expression
313 %************************************************************************
315 \subsection{STG right-hand sides}
317 %************************************************************************
319 Here's the rest of the interesting stuff for @StgLet@s; the first
320 flavour is for closures:
322 data GenStgRhs bndr occ
324 CostCentre -- cost centre to be attached (default is CCC)
325 StgBinderInfo -- Info about how this binder is used (see below)
326 [occ] -- non-global free vars; a list, rather than
327 -- a set, because order is important
328 UpdateFlag -- ReEntrant | Updatable | SingleEntry
329 [bndr] -- arguments; if empty, then not a function;
330 -- as above, order is important
331 (GenStgExpr bndr occ) -- body
333 An example may be in order. Consider:
335 let t = \x -> \y -> ... x ... y ... p ... q in e
337 Pulling out the free vars and stylising somewhat, we get the equivalent:
339 let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
341 Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
342 offsets from @Node@ into the closure, and the code ptr for the closure
343 will be exactly that in parentheses above.
345 The second flavour of right-hand-side is for constructors (simple but important):
348 CostCentre -- Cost centre to be attached (default is CCC).
349 -- Top-level (static) ones will end up with
350 -- DontCareCC, because we don't count static
351 -- data in heap profiles, and we don't set CCC
352 -- from static closure.
354 [GenStgArg occ] -- args
357 Here's the @StgBinderInfo@ type, and its combining op:
362 Bool -- At least one occurrence as an argument
364 Bool -- At least one occurrence in an unsaturated application
366 Bool -- This thing (f) has at least occurrence of the form:
367 -- x = [..] \u [] -> f a b c
368 -- where the application is saturated
370 Bool -- Ditto for non-updatable x.
372 Bool -- At least one fake application occurrence, that is
373 -- an StgApp f args where args is an empty list
374 -- This is due to the fact that we do not have a
375 -- StgVar constructor.
376 -- Used by the lambda lifter.
377 -- True => "at least one unsat app" is True too
379 stgArgOcc = StgBinderInfo True False False False False
380 stgUnsatOcc = StgBinderInfo False True False False False
381 stgStdHeapOcc = StgBinderInfo False False True False False
382 stgNoUpdHeapOcc = StgBinderInfo False False False True False
383 stgNormalOcc = StgBinderInfo False False False False False
384 -- [Andre] can't think of a good name for the last one.
385 stgFakeFunAppOcc = StgBinderInfo False True False False True
387 combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
389 combineStgBinderInfo NoStgBinderInfo info2 = info2
390 combineStgBinderInfo info1 NoStgBinderInfo = info1
391 combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
392 (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
393 = StgBinderInfo (arg1 || arg2)
395 (std_heap1 || std_heap2)
396 (upd_heap1 || upd_heap2)
400 %************************************************************************
402 \subsection[Stg-case-alternatives]{STG case alternatives}
404 %************************************************************************
406 Just like in @CoreSyntax@ (except no type-world stuff).
409 data GenStgCaseAlts bndr occ
410 = StgAlgAlts Type -- so we can find out things about constructor family
411 [(Id, -- alts: data constructor,
412 [bndr], -- constructor's parameters,
413 [Bool], -- "use mask", same length as
414 -- parameters; a True in a
415 -- param's position if it is
417 GenStgExpr bndr occ)] -- ...right-hand side.
418 (GenStgCaseDefault bndr occ)
419 | StgPrimAlts Type -- so we can find out things about constructor family
420 [(Literal, -- alts: unboxed literal,
421 GenStgExpr bndr occ)] -- rhs.
422 (GenStgCaseDefault bndr occ)
424 data GenStgCaseDefault bndr occ
425 = StgNoDefault -- small con family: all
426 -- constructor accounted for
427 | StgBindDefault bndr -- form: var -> expr
428 Bool -- True <=> var is used in rhs
429 -- i.e., False <=> "_ -> expr"
430 (GenStgExpr bndr occ)
433 %************************************************************************
435 \subsection[Stg]{The Plain STG parameterisation}
437 %************************************************************************
439 This happens to be the only one we use at the moment.
442 type StgBinding = GenStgBinding Id Id
443 type StgArg = GenStgArg Id
444 type StgLiveVars = GenStgLiveVars Id
445 type StgExpr = GenStgExpr Id Id
446 type StgRhs = GenStgRhs Id Id
447 type StgCaseAlts = GenStgCaseAlts Id Id
448 type StgCaseDefault = GenStgCaseDefault Id Id
451 %************************************************************************
453 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
455 %************************************************************************
457 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
460 data UpdateFlag = ReEntrant | Updatable | SingleEntry
462 instance Outputable UpdateFlag where
464 = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
467 %************************************************************************
469 \subsection[Stg-utility-functions]{Utility functions}
471 %************************************************************************
474 For doing interfaces, we want the exported top-level Ids from the
475 final pre-codegen STG code, so as to be sure we have the
476 latest/greatest pragma info.
479 collectFinalStgBinders
480 :: [StgBinding] -- input program
481 -> [Id] -- final externally-visible top-level Ids
483 collectFinalStgBinders binds
488 ex es ((StgNonRec b _) : binds)
489 = if not (externallyVisibleId b) then
494 ex es ((StgRec []) : binds) = ex es binds
496 ex es ((StgRec ((b, rhs) : pairs)) : binds)
497 = ex es (StgNonRec b rhs : (StgRec pairs : binds))
498 -- OK, a total hack; laziness rules
501 %************************************************************************
503 \subsection[Stg-pretty-printing]{Pretty-printing}
505 %************************************************************************
507 Robin Popplestone asked for semi-colon separators on STG binds; here's
508 hoping he likes terminators instead... Ditto for case alternatives.
511 pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
512 PprStyle -> GenStgBinding bndr bdee -> Pretty
514 pprStgBinding sty (StgNonRec bndr rhs)
515 = ppHang (ppCat [ppr sty bndr, ppEquals])
516 4 (ppBeside (ppr sty rhs) ppSemi)
518 pprStgBinding sty (StgCoerceBinding bndr occ)
519 = ppHang (ppCat [ppr sty bndr, ppEquals, ppStr "{-Coerce-}"])
520 4 (ppBeside (ppr sty occ) ppSemi)
522 pprStgBinding sty (StgRec pairs)
523 = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
524 (map (ppr_bind sty) pairs))
526 ppr_bind sty (bndr, expr)
527 = ppHang (ppCat [ppr sty bndr, ppEquals])
528 4 (ppBeside (ppr sty expr) ppSemi)
530 pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
531 pprPlainStgBinding sty b = pprStgBinding sty b
535 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
538 instance (Outputable bndr, Outputable bdee, Ord bdee)
539 => Outputable (GenStgBinding bndr bdee) where
542 instance (Outputable bndr, Outputable bdee, Ord bdee)
543 => Outputable (GenStgExpr bndr bdee) where
546 instance (Outputable bndr, Outputable bdee, Ord bdee)
547 => Outputable (GenStgRhs bndr bdee) where
548 ppr sty rhs = pprStgRhs sty rhs
552 pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
554 pprStgArg sty (StgVarArg var) = ppr sty var
555 pprStgArg sty (StgLitArg lit) = ppr sty lit
559 pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
560 PprStyle -> GenStgExpr bndr bdee -> Pretty
562 pprStgExpr sty (StgApp func [] lvs)
563 = ppBeside (ppr sty func) (pprStgLVs sty lvs)
566 pprStgExpr sty (StgApp func args lvs)
567 = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
568 4 (ppSep (map (ppr sty) args))
572 pprStgExpr sty (StgCon con args lvs)
573 = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
574 ppStr "! [", interppSP sty args, ppStr "]" ]
576 pprStgExpr sty (StgPrim op args lvs)
577 = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
578 ppStr " [", interppSP sty args, ppStr "]" ]
582 -- special case: let v = <very specific thing>
588 -- Very special! Suspicious! (SLPJ)
590 pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
593 (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
594 ppStr (showCostCentre sty True{-as string-} cc),
595 pp_binder_info sty bi,
596 ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
597 ppr sty upd_flag, ppStr " [",
598 interppSP sty args, ppStr "]"])
599 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
602 -- special case: let ... in let ...
604 pprStgExpr sty (StgLet bind expr@(StgLet _ _))
606 (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
610 pprStgExpr sty (StgLet bind expr)
611 = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
612 ppHang (ppStr "} in ") 2 (ppr sty expr)]
614 pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
615 = ppSep [ppHang (ppStr "let-no-escape {")
616 2 (pprStgBinding sty bind),
617 ppHang (ppBeside (ppStr "} in ")
620 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
621 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
627 pprStgExpr sty (StgSCC ty cc expr)
628 = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
629 pprStgExpr sty expr ]
633 pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
634 = ppSep [ppSep [ppStr "case",
635 ppNest 4 (ppCat [pprStgExpr sty expr,
636 ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
640 ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
641 ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
642 ppStr "]; uniq: ", pprUnique uniq])),
643 ppNest 2 (ppr_alts sty alts),
646 pp_ty (StgAlgAlts ty _ _) = ppr sty ty
647 pp_ty (StgPrimAlts ty _ _) = ppr sty ty
649 ppr_alts sty (StgAlgAlts ty alts deflt)
650 = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
651 ppr_default sty deflt ]
653 ppr_bxd_alt sty (con, params, use_mask, expr)
654 = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
655 4 (ppBeside (ppr sty expr) ppSemi)
659 then ppBesides [ppLparen, ppr sty con, ppRparen]
662 ppr_alts sty (StgPrimAlts ty alts deflt)
663 = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
664 ppr_default sty deflt ]
666 ppr_ubxd_alt sty (lit, expr)
667 = ppHang (ppCat [ppr sty lit, ppStr "->"])
668 4 (ppBeside (ppr sty expr) ppSemi)
670 ppr_default sty StgNoDefault = ppNil
671 ppr_default sty (StgBindDefault bndr used expr)
672 = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
674 pp_binder = if used then ppr sty bndr else ppChar '_'
678 -- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
680 pprStgLVs PprForUser lvs = ppNil
683 = if isEmptyUniqSet lvs then
686 ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
690 pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
691 PprStyle -> GenStgRhs bndr bdee -> Pretty
694 pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
695 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
696 pp_binder_info sty bi,
697 ppStr " [", ifPprDebug sty (ppr sty free_var),
698 ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
700 pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
701 = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
702 pp_binder_info sty bi,
703 ppStr " [", ifPprDebug sty (interppSP sty free_vars),
704 ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
707 pprStgRhs sty (StgRhsCon cc con args)
708 = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
709 ppSP, ppr sty con, ppStr "! [", interppSP sty args, ppStr "]" ]
712 pp_binder_info PprForUser _ = ppNil
714 pp_binder_info sty NoStgBinderInfo = ppNil
716 -- cases so boring that we print nothing
717 pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
720 pp_binder_info sty (StgBinderInfo a b c d e)
721 = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
723 pp_bool x = ppr (panic "pp_bool") x
726 Collect @IdInfo@ stuff that is most easily just snaffled straight
727 from the STG bindings.
730 stgArity :: StgRhs -> Int
732 stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
733 stgArity (StgRhsClosure _ _ _ _ args _ ) = length args