%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
%************************************************************************
%* *
%************************************************************************
We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
-@TyVars@ as well. Currently trying the former.
+@TyVars@ as well. Currently trying the former... MEGA SIGH.
\begin{code}
-#include "HsVersions.h"
-
module HsCore (
- UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
- UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
- UnfoldingCoreAtom(..), UfId(..), SYN_IE(UnfoldingType),
- UnfoldingPrimOp(..), UfCostCentre(..)
+ UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
+ UfBinding(..), UfCon(..)
) where
-IMP_Ubiq()
+#include "HsVersions.h"
-- friends:
-import HsTypes ( MonoType, PolyType )
-import PrimOp ( PrimOp, tagOf_PrimOp )
+import HsTypes ( HsType, pprParendHsType )
-- others:
-import Literal ( Literal )
-import Outputable ( Outputable(..) )
-import Pretty
-import Util ( panic )
+import Const ( Literal )
+import Type ( Kind )
+import CostCentre
+import Outputable
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data UnfoldingCoreExpr name
- = UfVar (UfId name)
- | UfLit Literal
- | UfCon name -- must be a "BoringUfId"...
- [UnfoldingType name]
- [UnfoldingCoreAtom name]
- | UfPrim (UnfoldingPrimOp name)
- [UnfoldingType name]
- [UnfoldingCoreAtom name]
- | UfLam (UfBinder name)
- (UnfoldingCoreExpr name)
- | UfApp (UnfoldingCoreExpr name)
- (UnfoldingCoreAtom name)
- | UfCase (UnfoldingCoreExpr name)
- (UnfoldingCoreAlts name)
- | UfLet (UnfoldingCoreBinding name)
- (UnfoldingCoreExpr name)
- | UfSCC (UfCostCentre name)
- (UnfoldingCoreExpr name)
-
-data UnfoldingPrimOp name
- = UfCCallOp FAST_STRING -- callee
- Bool -- True <=> casm, rather than ccall
- Bool -- True <=> might cause GC
- [UnfoldingType name] -- arg types, incl state token
- -- (which will be first)
- (UnfoldingType name) -- return type
- | UfOtherOp PrimOp
-
-data UnfoldingCoreAlts name
- = UfCoAlgAlts [(name, [UfBinder name], UnfoldingCoreExpr name)]
- (UnfoldingCoreDefault name)
- | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)]
- (UnfoldingCoreDefault name)
-
-data UnfoldingCoreDefault name
- = UfCoNoDefault
- | UfCoBindDefault (UfBinder name)
- (UnfoldingCoreExpr name)
-
-data UnfoldingCoreBinding name
- = UfCoNonRec (UfBinder name)
- (UnfoldingCoreExpr name)
- | UfCoRec [(UfBinder name, UnfoldingCoreExpr name)]
-
-data UnfoldingCoreAtom name
- = UfCoVarAtom (UfId name)
- | UfCoLitAtom Literal
-
-data UfCostCentre name
- = UfPreludeDictsCC
- Bool -- True <=> is dupd
- | UfAllDictsCC FAST_STRING -- module and group
- FAST_STRING
- Bool -- True <=> is dupd
- | UfUserCC FAST_STRING
- FAST_STRING FAST_STRING -- module and group
- Bool -- True <=> is dupd
- Bool -- True <=> is CAF
- | UfAutoCC (UfId name)
- FAST_STRING FAST_STRING -- module and group
- Bool Bool -- as above
- | UfDictCC (UfId name)
- FAST_STRING FAST_STRING -- module and group
- Bool Bool -- as above
-
-type UfBinder name = (name, UnfoldingType name)
-
-data UfId name
- = BoringUfId name
- | SuperDictSelUfId name name -- class and superclass
- | ClassOpUfId name name -- class and class op
- | DictFunUfId name -- class and type
- (UnfoldingType name)
- | ConstMethodUfId name name -- class, class op, and type
- (UnfoldingType name)
- | DefaultMethodUfId name name -- class and class op
- | SpecUfId (UfId name) -- its unspecialised "parent"
- [Maybe (MonoType name)]
- | WorkerUfId (UfId name) -- its non-working "parent"
- -- more to come?
-
-type UnfoldingType name = PolyType name
+data UfExpr name
+ = UfVar name
+ | UfType (HsType name)
+ | UfCon (UfCon name) [UfExpr name]
+ | UfTuple name [UfExpr name] -- Type arguments omitted
+ | UfLam (UfBinder name) (UfExpr name)
+ | UfApp (UfExpr name) (UfExpr name)
+ | UfCase (UfExpr name) name [UfAlt name]
+ | UfLet (UfBinding name) (UfExpr name)
+ | UfNote (UfNote name) (UfExpr name)
+
+data UfNote name = UfSCC CostCentre
+ | UfCoerce (HsType name)
+ | UfInlineCall
+
+type UfAlt name = (UfCon name, [name], UfExpr name)
+
+data UfCon name = UfDefault
+ | UfDataCon name
+ | UfLitCon Literal
+ | UfLitLitCon FAST_STRING (HsType name)
+ | UfPrimOp name
+ | UfCCallOp FAST_STRING -- callee
+ Bool -- True <=> casm, rather than ccall
+ Bool -- True <=> might cause GC
+
+data UfBinding name
+ = UfNonRec (UfBinder name)
+ (UfExpr name)
+ | UfRec [(UfBinder name, UfExpr name)]
+
+data UfBinder name
+ = UfValBinder name (HsType name)
+ | UfTyBinder name Kind
\end{code}
+
%************************************************************************
%* *
\subsection[HsCore-print]{Printing Core unfoldings}
%************************************************************************
\begin{code}
-instance Outputable name => Outputable (UnfoldingCoreExpr name) where
- ppr sty (UfVar v) = pprUfId sty v
- ppr sty (UfLit l) = ppr sty l
+instance Outputable name => Outputable (UfExpr name) where
+ ppr (UfVar v) = ppr v
+ ppr (UfType ty) = char '@' <+> pprParendHsType ty
+
+ ppr (UfCon c as)
+ = hsep [text "UfCon", ppr c, ppr as]
- ppr sty (UfCon c tys as)
- = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
- ppr sty (UfPrim o tys as)
- = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
+ ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
- ppr sty (UfLam bs body)
- = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
+ ppr (UfLam b body)
+ = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
- ppr sty (UfApp fun arg)
- = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
+ ppr (UfApp fun arg) = ppr fun <+> ppr arg
- ppr sty (UfCase scrut alts)
- = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
+ ppr (UfCase scrut bndr alts)
+ = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
+ braces (hsep (punctuate semi (map pp_alt alts)))]
where
- pp_alts (UfCoAlgAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
- where
- pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
- pp_alts (UfCoPrimAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
- where
- pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
-
- pp_deflt UfCoNoDefault = ppNil
- pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
-
- ppr sty (UfLet (UfCoNonRec b rhs) body)
- = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
- ppr sty (UfLet (UfCoRec pairs) body)
- = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
+ pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
+
+ ppr_arrow = ptext SLIT("->")
+
+ ppr (UfLet (UfNonRec b rhs) body)
+ = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
+ ppr (UfLet (UfRec pairs) body)
+ = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
where
- pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
-
- ppr sty (UfSCC uf_cc body)
- = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
-
-instance Outputable name => Outputable (UnfoldingPrimOp name) where
- ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
- = let
- before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
- after = if is_casm then ppStr "'' " else ppSP
- in
- ppBesides [before, ppPStr str, after,
- ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
- ppr sty (UfOtherOp op)
- = ppr sty op
-
-instance Outputable name => Outputable (UnfoldingCoreAtom name) where
- ppr sty (UfCoVarAtom v) = pprUfId sty v
- ppr sty (UfCoLitAtom l) = ppr sty l
-
-pprUfId sty (BoringUfId v) = ppr sty v
-pprUfId sty (SuperDictSelUfId c sc)
- = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
-pprUfId sty (ClassOpUfId c op)
- = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
-pprUfId sty (DictFunUfId c ty)
- = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (ConstMethodUfId c op ty)
- = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (DefaultMethodUfId c ty)
- = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-
-pprUfId sty (SpecUfId unspec ty_maybes)
- = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
- ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
- where
- pp_ty_maybe Nothing = ppStr "_N_"
- pp_ty_maybe (Just t) = ppr sty t
-
-pprUfId sty (WorkerUfId unwrkr)
- = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
+ pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
+
+ ppr (UfNote note body)
+ = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
+
+instance Outputable name => Outputable (UfCon name) where
+ ppr UfDefault = text "DEFAULT"
+ ppr (UfDataCon d) = ppr d
+ ppr (UfPrimOp p) = ppr p
+ ppr (UfCCallOp str is_casm can_gc)
+ = hcat [before, ptext str, after]
+ where
+ before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
+ after = if is_casm then text "'' " else space
+
+instance Outputable name => Outputable (UfBinder name) where
+ ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty]
+ ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
\end{code}
projects / ghc-hetmet.git / blobdiff