suited to spineless tagless code generation.
\begin{code}
-#include "HsVersions.h"
-
module StgSyn (
GenStgArg(..),
- GenStgLiveVars(..),
+ GenStgLiveVars,
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
GenStgCaseAlts(..), GenStgCaseDefault(..),
combineStgBinderInfo,
-- a set of synonyms for the most common (only :-) parameterisation
- StgArg(..), StgLiveVars(..),
- StgBinding(..), StgExpr(..), StgRhs(..),
- StgCaseAlts(..), StgCaseDefault(..),
+ StgArg, StgLiveVars,
+ StgBinding, StgExpr, StgRhs,
+ StgCaseAlts, StgCaseDefault,
- pprPlainStgBinding,
+ pprStgBinding, pprStgBindings,
getArgPrimRep,
isLitLitArg,
stgArity,
- collectExportedStgBinders
-
- -- and to make the interface self-sufficient...
+ collectFinalStgBinders
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
-import CostCentre ( showCostCentre )
-import Id ( idPrimRep, GenId{-instance NamedThing-} )
+import CostCentre ( showCostCentre, CostCentre )
+import Id ( idPrimRep, DataCon,
+ GenId{-instance NamedThing-}, Id )
import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
-import Name ( isExported, isSymLexeme )
-import Outputable ( ifPprDebug, interppSP, interpp'SP,
- Outputable(..){-instance * Bool-}
- )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
-import Pretty -- all of it
+import Outputable
import PrimOp ( PrimOp{-instance Outputable-} )
-import Unique ( pprUnique )
-import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet(..) )
+import Type ( Type )
+import Unique ( pprUnique, Unique )
+import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import Util ( panic )
\end{code}
data GenStgBinding bndr occ
= StgNonRec bndr (GenStgRhs bndr occ)
| StgRec [(bndr, GenStgRhs bndr occ)]
+ | StgCoerceBinding bndr occ -- UNUSED?
\end{code}
%************************************************************************
data GenStgArg occ
= StgVarArg occ
| StgLitArg Literal
+ | StgConArg DataCon -- A nullary data constructor
\end{code}
\begin{code}
getArgPrimRep (StgVarArg local) = idPrimRep local
+getArgPrimRep (StgConArg con) = idPrimRep con
getArgPrimRep (StgLitArg lit) = literalPrimRep lit
isLitLitArg (StgLitArg x) = isLitLitLit x
data UpdateFlag = ReEntrant | Updatable | SingleEntry
instance Outputable UpdateFlag where
- ppr sty u
- = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
+ ppr u
+ = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' })
\end{code}
%************************************************************************
latest/greatest pragma info.
\begin{code}
-collectExportedStgBinders
+collectFinalStgBinders
:: [StgBinding] -- input program
- -> [Id] -- exported top-level Ids
+ -> [Id]
-collectExportedStgBinders binds
- = ex [] binds
- where
- ex es [] = es
-
- ex es ((StgNonRec b _) : binds)
- = if not (isExported b) then
- ex es binds
- else
- ex (b:es) binds
-
- ex es ((StgRec []) : binds) = ex es binds
-
- ex es ((StgRec ((b, rhs) : pairs)) : binds)
- = ex es (StgNonRec b rhs : (StgRec pairs : binds))
- -- OK, a total hack; laziness rules
+collectFinalStgBinders [] = []
+collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
+collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
\end{code}
%************************************************************************
hoping he likes terminators instead... Ditto for case alternatives.
\begin{code}
-pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
- PprStyle -> GenStgBinding bndr bdee -> Pretty
+pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
+ => GenStgBinding bndr bdee -> SDoc
+
+pprGenStgBinding (StgNonRec bndr rhs)
+ = hang (hsep [ppr bndr, equals])
+ 4 ((<>) (ppr rhs) semi)
-pprStgBinding sty (StgNonRec bndr rhs)
- = ppHang (ppCat [ppr sty bndr, ppEquals])
- 4 (ppBeside (ppr sty rhs) ppSemi)
+pprGenStgBinding (StgCoerceBinding bndr occ)
+ = hang (hsep [ppr bndr, equals, ptext SLIT("{-Coerce-}")])
+ 4 ((<>) (ppr occ) semi)
-pprStgBinding sty (StgRec pairs)
- = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
- (map (ppr_bind sty) pairs))
+pprGenStgBinding (StgRec pairs)
+ = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
+ (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
where
- ppr_bind sty (bndr, expr)
- = ppHang (ppCat [ppr sty bndr, ppEquals])
- 4 (ppBeside (ppr sty expr) ppSemi)
+ ppr_bind (bndr, expr)
+ = hang (hsep [ppr bndr, equals])
+ 4 ((<>) (ppr expr) semi)
-pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
-pprPlainStgBinding sty b = pprStgBinding sty b
+pprStgBinding :: StgBinding -> SDoc
+pprStgBinding bind = pprGenStgBinding bind
+
+pprStgBindings :: [StgBinding] -> SDoc
+pprStgBindings binds = vcat (map (pprGenStgBinding) binds)
\end{code}
\begin{code}
instance (Outputable bndr, Outputable bdee, Ord bdee)
=> Outputable (GenStgBinding bndr bdee) where
- ppr = pprStgBinding
+ ppr = pprGenStgBinding
instance (Outputable bndr, Outputable bdee, Ord bdee)
=> Outputable (GenStgExpr bndr bdee) where
instance (Outputable bndr, Outputable bdee, Ord bdee)
=> Outputable (GenStgRhs bndr bdee) where
- ppr sty rhs = pprStgRhs sty rhs
+ ppr rhs = pprStgRhs rhs
\end{code}
\begin{code}
-pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
+pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
-pprStgArg sty (StgVarArg var) = ppr sty var
-pprStgArg sty (StgLitArg lit) = ppr sty lit
+pprStgArg (StgVarArg var) = ppr var
+pprStgArg (StgConArg con) = ppr con
+pprStgArg (StgLitArg lit) = ppr lit
\end{code}
\begin{code}
-pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
- PprStyle -> GenStgExpr bndr bdee -> Pretty
+pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
+ => GenStgExpr bndr bdee -> SDoc
-- special case
-pprStgExpr sty (StgApp func [] lvs)
- = ppBeside (ppr sty func) (pprStgLVs sty lvs)
+pprStgExpr (StgApp func [] lvs)
+ = (<>) (ppr func) (pprStgLVs lvs)
-- general case
-pprStgExpr sty (StgApp func args lvs)
- = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
- 4 (ppSep (map (ppr sty) args))
+pprStgExpr (StgApp func args lvs)
+ = hang ((<>) (ppr func) (pprStgLVs lvs))
+ 4 (sep (map (ppr) args))
\end{code}
\begin{code}
-pprStgExpr sty (StgCon con args lvs)
- = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
- ppStr "! [", interppSP sty args, ppStr "]" ]
+pprStgExpr (StgCon con args lvs)
+ = hcat [ (<>) (ppr con) (pprStgLVs lvs),
+ ptext SLIT("! ["), interppSP args, char ']' ]
-pprStgExpr sty (StgPrim op args lvs)
- = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
- ppStr " [", interppSP sty args, ppStr "]" ]
+pprStgExpr (StgPrim op args lvs)
+ = hcat [ ppr op, char '#', pprStgLVs lvs,
+ ptext SLIT(" ["), interppSP args, char ']' ]
\end{code}
\begin{code}
--
-- Very special! Suspicious! (SLPJ)
-pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
expr@(StgLet _ _))
- = ppAbove
- (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
- ppStr (showCostCentre sty True{-as string-} cc),
- pp_binder_info sty bi,
- ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
- ppr sty upd_flag, ppStr " [",
- interppSP sty args, ppStr "]"])
- 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
- (ppr sty expr)
+ = ($$)
+ (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
+ text (showCostCentre True{-as string-} cc),
+ pp_binder_info bi,
+ ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
+ ppr upd_flag, ptext SLIT(" ["),
+ interppSP args, char ']'])
+ 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
+ (ppr expr)
-- special case: let ... in let ...
-pprStgExpr sty (StgLet bind expr@(StgLet _ _))
- = ppAbove
- (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
- (ppr sty expr)
+pprStgExpr (StgLet bind expr@(StgLet _ _))
+ = ($$)
+ (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
+ (ppr expr)
-- general case
-pprStgExpr sty (StgLet bind expr)
- = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
- ppHang (ppStr "} in ") 2 (ppr sty expr)]
-
-pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
- = ppSep [ppHang (ppStr "let-no-escape {")
- 2 (pprStgBinding sty bind),
- ppHang (ppBeside (ppStr "} in ")
- (ifPprDebug sty (
- ppNest 4 (
- ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
- ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
- ppStr "]"]))))
- 2 (ppr sty expr)]
+pprStgExpr (StgLet bind expr)
+ = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
+ hang (ptext SLIT("} in ")) 2 (ppr expr)]
+
+pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
+ = sep [hang (ptext SLIT("let-no-escape {"))
+ 2 (pprGenStgBinding bind),
+ hang ((<>) (ptext SLIT("} in "))
+ (ifPprDebug (
+ nest 4 (
+ hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+ ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+ char ']']))))
+ 2 (ppr expr)]
\end{code}
\begin{code}
-pprStgExpr sty (StgSCC ty cc expr)
- = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
- pprStgExpr sty expr ]
+pprStgExpr (StgSCC ty cc expr)
+ = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre True{-as string-} cc)],
+ pprStgExpr expr ]
\end{code}
\begin{code}
-pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
- = ppSep [ppSep [ppStr "case",
- ppNest 4 (ppCat [pprStgExpr sty expr,
- ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
- ppStr "of {"],
- ifPprDebug sty (
- ppNest 4 (
- ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
- ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
- ppStr "]; uniq: ", pprUnique uniq])),
- ppNest 2 (ppr_alts sty alts),
- ppStr "}"]
+pprStgExpr (StgCase expr lvs_whole lvs_rhss uniq alts)
+ = sep [sep [ptext SLIT("case"),
+ nest 4 (hsep [pprStgExpr expr,
+ ifPprDebug (ptext SLIT("::") <> pp_ty alts)]),
+ ptext SLIT("of {")],
+ ifPprDebug (
+ nest 4 (
+ hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+ ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+ ptext SLIT("]; uniq: "), pprUnique uniq])),
+ nest 2 (ppr_alts alts),
+ char '}']
where
- pp_ty (StgAlgAlts ty _ _) = ppr sty ty
- pp_ty (StgPrimAlts ty _ _) = ppr sty ty
-
- ppr_alts sty (StgAlgAlts ty alts deflt)
- = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
- ppr_default sty deflt ]
+ ppr_default StgNoDefault = empty
+ ppr_default (StgBindDefault bndr used expr)
+ = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr expr)
where
- ppr_bxd_alt sty (con, params, use_mask, expr)
- = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
- 4 (ppBeside (ppr sty expr) ppSemi)
- where
- ppr_con sty con
- = if isSymLexeme con
- then ppBesides [ppLparen, ppr sty con, ppRparen]
- else ppr sty con
-
- ppr_alts sty (StgPrimAlts ty alts deflt)
- = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
- ppr_default sty deflt ]
+ pp_binder = if used then ppr bndr else char '_'
+
+ pp_ty (StgAlgAlts ty _ _) = ppr ty
+ pp_ty (StgPrimAlts ty _ _) = ppr ty
+
+ ppr_alts (StgAlgAlts ty alts deflt)
+ = vcat [ vcat (map (ppr_bxd_alt) alts),
+ ppr_default deflt ]
where
- ppr_ubxd_alt sty (lit, expr)
- = ppHang (ppCat [ppr sty lit, ppStr "->"])
- 4 (ppBeside (ppr sty expr) ppSemi)
+ ppr_bxd_alt (con, params, use_mask, expr)
+ = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
+ 4 ((<>) (ppr expr) semi)
- ppr_default sty StgNoDefault = ppNil
- ppr_default sty (StgBindDefault bndr used expr)
- = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
+ ppr_alts (StgPrimAlts ty alts deflt)
+ = vcat [ vcat (map (ppr_ubxd_alt) alts),
+ ppr_default deflt ]
where
- pp_binder = if used then ppr sty bndr else ppChar '_'
+ ppr_ubxd_alt (lit, expr)
+ = hang (hsep [ppr lit, ptext SLIT("->")])
+ 4 ((<>) (ppr expr) semi)
\end{code}
\begin{code}
--- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
-
-pprStgLVs PprForUser lvs = ppNil
-
-pprStgLVs sty lvs
- = if isEmptyUniqSet lvs then
- ppNil
+pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
+pprStgLVs lvs
+ = getPprStyle $ \ sty ->
+ if userStyle sty || isEmptyUniqSet lvs then
+ empty
else
- ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
+ hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
\end{code}
\begin{code}
-pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
- PprStyle -> GenStgRhs bndr bdee -> Pretty
+pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
+ => GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
- = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
- pp_binder_info sty bi,
- ppStr " [", ifPprDebug sty (ppr sty free_var),
- ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
+pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
+ = hcat [ text (showCostCentre True{-as String-} cc),
+ pp_binder_info bi,
+ brackets (ifPprDebug (ppr free_var)),
+ ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
+
-- general case
-pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body)
- = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
- pp_binder_info sty bi,
- ppStr " [", ifPprDebug sty (interppSP sty free_vars),
- ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
- 4 (ppr sty body)
+pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
+ = hang (hcat [text (showCostCentre True{-as String-} cc),
+ pp_binder_info bi,
+ brackets (ifPprDebug (interppSP free_vars)),
+ ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
+ 4 (ppr body)
-pprStgRhs sty (StgRhsCon cc con args)
- = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
- ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ]
+pprStgRhs (StgRhsCon cc con args)
+ = hcat [ text (showCostCentre True{-as String-} cc),
+ space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
--------------
-pp_binder_info PprForUser _ = ppNil
-pp_binder_info sty NoStgBinderInfo = ppNil
+pp_binder_info NoStgBinderInfo = empty
-- cases so boring that we print nothing
-pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
+pp_binder_info (StgBinderInfo True b c d e) = empty
-- general case
-pp_binder_info sty (StgBinderInfo a b c d e)
- = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
- where
- pp_bool x = ppr (panic "pp_bool") x
+pp_binder_info (StgBinderInfo a b c d e)
+ = getPprStyle $ \ sty ->
+ if userStyle sty then
+ empty
+ else
+ parens (hsep (punctuate comma (map ppr [a,b,c,d,e])))
\end{code}
Collect @IdInfo@ stuff that is most easily just snaffled straight
projects / ghc-hetmet.git / blobdiff