%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
%************************************************************************
%* *
@TyVars@ as well. Currently trying the former... MEGA SIGH.
\begin{code}
-#include "HsVersions.h"
-
module HsCore (
- UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
- UfDefault(..), UfBinding(..),
- UfArg(..), UfPrimOp(..)
+ UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
+ UfBinding(..), UfConAlt(..),
+ HsIdInfo(..), HsStrictnessInfo(..),
+ IfaceSig(..), UfRuleBody(..)
) where
-IMP_Ubiq()
+#include "HsVersions.h"
-- friends:
import HsTypes ( HsType, pprParendHsType )
-import PrimOp ( PrimOp, tagOf_PrimOp )
-import Kind ( Kind {- instance Outputable -} )
-import Type ( GenType {- instance Outputable -} )
-- others:
+import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo )
+import CoreSyn ( CoreBndr, CoreExpr )
+import Demand ( Demand )
import Literal ( Literal )
-import Outputable ( Outputable(..) )
-import Pretty
-import Util ( panic )
+import PrimOp ( CCall, pprCCallOp )
+import Type ( Kind )
+import CostCentre
+import SrcLoc ( SrcLoc )
+import Outputable
\end{code}
%************************************************************************
\begin{code}
data UfExpr name
= UfVar name
- | UfLit Literal
- | UfCon name [UfArg name]
- | UfPrim (UfPrimOp name) [UfArg name]
+ | UfType (HsType name)
+ | UfTuple name [UfExpr name] -- Type arguments omitted
| UfLam (UfBinder name) (UfExpr name)
- | UfApp (UfExpr name) (UfArg name)
- | UfCase (UfExpr name) (UfAlts name)
+ | UfApp (UfExpr name) (UfExpr name)
+ | UfCase (UfExpr name) name [UfAlt name]
| UfLet (UfBinding name) (UfExpr name)
- | UfSCC CostCentre (UfExpr name)
- | UfCoerce (UfCoercion name) (HsType name) (UfExpr name)
-
-data UfPrimOp name
- = UfCCallOp FAST_STRING -- callee
- Bool -- True <=> casm, rather than ccall
- Bool -- True <=> might cause GC
- [HsType name] -- arg types, incl state token
- -- (which will be first)
- (HsType name) -- return type
-
- | UfOtherOp name
+ | UfNote (UfNote name) (UfExpr name)
+ | UfLit Literal
+ | UfLitLit FAST_STRING (HsType name)
+ | UfCCall CCall (HsType name)
-data UfCoercion name = UfIn name | UfOut name
+data UfNote name = UfSCC CostCentre
+ | UfCoerce (HsType name)
+ | UfInlineCall
+ | UfInlineMe
-data UfAlts name
- = UfAlgAlts [(name, [name], UfExpr name)]
- (UfDefault name)
- | UfPrimAlts [(Literal, UfExpr name)]
- (UfDefault name)
+type UfAlt name = (UfConAlt name, [name], UfExpr name)
-data UfDefault name
- = UfNoDefault
- | UfBindDefault name (UfExpr name)
+data UfConAlt name = UfDefault
+ | UfDataAlt name
+ | UfLitAlt Literal
+ | UfLitLitAlt FAST_STRING (HsType name)
data UfBinding name
= UfNonRec (UfBinder name)
data UfBinder name
= UfValBinder name (HsType name)
| UfTyBinder name Kind
- | UfUsageBinder name
-
-data UfArg name
- = UfVarArg name
- | UfLitArg Literal
- | UfTyArg (HsType name)
- | UfUsageArg name
\end{code}
+
%************************************************************************
%* *
\subsection[HsCore-print]{Printing Core unfoldings}
\begin{code}
instance Outputable name => Outputable (UfExpr name) where
- ppr sty (UfVar v) = ppr sty v
- ppr sty (UfLit l) = ppr sty l
+ ppr (UfVar v) = ppr v
+ ppr (UfLit l) = ppr l
- ppr sty (UfCon c as)
- = ppCat [ppStr "UfCon", ppr sty c, ppr sty as, ppChar ')']
- ppr sty (UfPrim o as)
- = ppCat [ppStr "UfPrim", ppr sty o, ppr sty as, ppChar ')']
+ ppr (UfLitLit l ty) = ppr l
+ ppr (UfCCall cc ty) = pprCCallOp cc
- ppr sty (UfLam b body)
- = ppCat [ppChar '\\', ppr sty b, ppPStr SLIT("->"), ppr sty body]
+ ppr (UfType ty) = char '@' <+> pprParendHsType ty
- ppr sty (UfApp fun (UfTyArg ty))
- = ppCat [ppr sty fun, ppChar '@', pprParendHsType sty ty]
+ ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
- ppr sty (UfApp fun (UfLitArg lit))
- = ppCat [ppr sty fun, ppr sty lit]
+ ppr (UfLam b body)
+ = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
- ppr sty (UfApp fun (UfVarArg var))
- = ppCat [ppr sty fun, ppr sty var]
+ ppr (UfApp fun arg) = ppr fun <+> ppr arg
- ppr sty (UfCase scrut alts)
- = ppCat [ppPStr SLIT("case"), ppr sty scrut, ppPStr SLIT("of {"), pp_alts alts, ppChar '}']
+ 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 (UfAlgAlts 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, ppr_arrow, ppr sty rhs]
- pp_alts (UfPrimAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
- where
- pp_alt (l,rhs) = ppCat [ppr sty l, ppr_arrow, ppr sty rhs]
-
- pp_deflt UfNoDefault = ppNil
- pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppr_arrow, ppr sty rhs]
-
- ppr_arrow = ppPStr SLIT("->")
-
- ppr sty (UfLet (UfNonRec b rhs) body)
- = ppCat [ppPStr SLIT("let"), ppr sty b, ppEquals, ppr sty rhs, ppPStr SLIT("in"), ppr sty body]
- ppr sty (UfLet (UfRec pairs) body)
- = ppCat [ppPStr SLIT("letrec {"), ppInterleave ppSemi (map pp_pair pairs), ppPStr SLIT("} in"), ppr sty body]
- where
- pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
+ pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
- ppr sty (UfSCC uf_cc body)
- = ppCat [ppPStr SLIT("_scc_ <cost-centre[ToDo]>"), ppr sty body]
+ ppr_arrow = ptext SLIT("->")
-instance Outputable name => Outputable (UfPrimOp name) where
- ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
- = let
- before = ppPStr (if is_casm then SLIT("_casm_ ``") else SLIT("_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 (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) = hsep [ppr b, equals, ppr rhs]
- ppr sty (UfOtherOp op)
- = ppr sty op
+ ppr (UfNote note body)
+ = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
-instance Outputable name => Outputable (UfArg name) where
- ppr sty (UfVarArg v) = ppr sty v
- ppr sty (UfLitArg l) = ppr sty l
- ppr sty (UfTyArg ty) = pprParendHsType sty ty
- ppr sty (UfUsageArg name) = ppr sty name
+instance Outputable name => Outputable (UfConAlt name) where
+ ppr UfDefault = text "DEFAULT"
+ ppr (UfLitAlt l) = ppr l
+ ppr (UfLitLitAlt l ty) = ppr l
+ ppr (UfDataAlt d) = ppr d
instance Outputable name => Outputable (UfBinder name) where
- ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty ty]
- ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty kind]
- ppr sty (UfUsageBinder name) = ppr sty name
+ ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty]
+ ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Signatures in interface files}
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceSig name
+ = IfaceSig name
+ (HsType name)
+ [HsIdInfo name]
+ SrcLoc
+
+instance (Outputable name) => Outputable (IfaceSig name) where
+ ppr (IfaceSig var ty info _)
+ = hang (hsep [ppr var, dcolon])
+ 4 (ppr ty $$ ifPprDebug (vcat (map ppr info)))
+
+data HsIdInfo name
+ = HsArity ArityInfo
+ | HsStrictness HsStrictnessInfo
+ | HsUnfold InlinePragInfo (UfExpr name)
+ | HsUpdate UpdateInfo
+ | HsSpecialise (UfRuleBody name)
+ | HsNoCafRefs
+ | HsCprInfo
+ | HsWorker name -- Worker, if any
+
+instance Outputable name => Outputable (HsIdInfo name) where
+ ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf
+ ppr other = empty -- Havn't got around to this yet
+
+data HsStrictnessInfo
+ = HsStrictnessInfo ([Demand], Bool)
+ | HsBottom
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Rules in interface files}
+%* *
+%************************************************************************
+
+\begin{code}
+data UfRuleBody name = UfRuleBody FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name) -- Pre typecheck
+ | CoreRuleBody FAST_STRING [CoreBndr] [CoreExpr] CoreExpr -- Post typecheck
+\end{code}
projects / ghc-hetmet.git / blobdiff