%************************************************************************
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 (
- -- types:
- UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
- UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
- UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
- UnfoldingPrimOp(..), UfCostCentre(..),
-
- -- function:
- eqUfExpr
+ UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
+ UfDefault(..), UfBinding(..),
+ UfArg(..), UfPrimOp(..)
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
-- friends:
-import HsTypes ( cmpPolyType, MonoType(..), PolyType(..) )
+import HsTypes ( HsType, pprParendHsType )
import PrimOp ( PrimOp, tagOf_PrimOp )
+import Kind ( Kind {- instance Outputable -} )
+import Type ( GenType {- instance Outputable -} )
-- others:
import Literal ( Literal )
-import Outputable ( Outputable(..) {-instances-} )
-import Pretty
-import ProtoName ( cmpProtoName, eqProtoName, ProtoName )
import Util ( panic )
+import CostCentre
+import Outputable
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data UnfoldingCoreExpr name
- = UfVar (UfId name)
+data UfExpr name
+ = UfVar 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
+ | UfCon name [UfArg name]
+ | UfPrim (UfPrimOp name) [UfArg name]
+ | UfLam (UfBinder name) (UfExpr name)
+ | UfApp (UfExpr name) (UfArg name)
+ | UfCase (UfExpr name) (UfAlts 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
- [UnfoldingType name] -- arg types, incl state token
+ [HsType 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
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[HsCore-print]{Printing Core unfoldings}
-%* *
-%************************************************************************
+ (HsType name) -- return type
-\begin{code}
-instance Outputable name => Outputable (UnfoldingCoreExpr name) where
- ppr sty (UfVar v) = pprUfId sty v
- ppr sty (UfLit l) = ppr sty l
+ | UfOtherOp name
- 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 ")"]
+data UfCoercion name = UfIn name | UfOut name
- ppr sty (UfLam bs body)
- = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
+data UfAlts name
+ = UfAlgAlts [(name, [name], UfExpr name)]
+ (UfDefault name)
+ | UfPrimAlts [(Literal, UfExpr name)]
+ (UfDefault name)
- ppr sty (UfApp fun arg)
- = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
+data UfDefault name
+ = UfNoDefault
+ | UfBindDefault name (UfExpr name)
- ppr sty (UfCase scrut alts)
- = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
- 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]
+data UfBinding name
+ = UfNonRec (UfBinder name)
+ (UfExpr name)
+ | UfRec [(UfBinder name, UfExpr name)]
- pp_deflt UfCoNoDefault = ppNil
- pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
+data UfBinder name
+ = UfValBinder name (HsType name)
+ | UfTyBinder name Kind
- 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]
- 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 ")"]
+data UfArg name
+ = UfVarArg name
+ | UfLitArg Literal
+ | UfTyArg (HsType name)
\end{code}
%************************************************************************
%* *
-\subsection[HsCore-equality]{Comparing Core unfoldings}
+\subsection[HsCore-print]{Printing Core unfoldings}
%* *
%************************************************************************
-We want to check that they are {\em exactly} the same.
-
\begin{code}
---eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool
-
-eqUfExpr (UfVar v1) (UfVar v2) = eqUfId v1 v2
-eqUfExpr (UfLit l1) (UfLit l2) = l1 == l2
-
-eqUfExpr (UfCon c1 tys1 as1) (UfCon c2 tys2 as2)
- = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
-eqUfExpr (UfPrim o1 tys1 as1) (UfPrim o2 tys2 as2)
- = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
- where
- eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True
- eq_op (UfOtherOp o1) (UfOtherOp o2)
- = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2
-
-eqUfExpr (UfLam bs1 body1) (UfLam bs2 body2)
- = eq_binder bs1 bs2 && eqUfExpr body1 body2
-
-eqUfExpr (UfApp fun1 arg1) (UfApp fun2 arg2)
- = eqUfExpr fun1 fun2 && eq_atom arg1 arg2
-
-eqUfExpr (UfCase scrut1 alts1) (UfCase scrut2 alts2)
- = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2
- where
- eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2)
- = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
- where
- eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2)
- = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2
+instance Outputable name => Outputable (UfExpr name) where
+ ppr (UfVar v) = ppr v
+ ppr (UfLit l) = ppr l
- eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2)
- = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
- where
- eq_alt (l1,rhs1) (l2,rhs2)
- = l1 == l2 && eqUfExpr rhs1 rhs2
+ ppr (UfCon c as)
+ = hsep [text "UfCon", ppr c, ppr as, char ')']
+ ppr (UfPrim o as)
+ = hsep [text "UfPrim", ppr o, ppr as, char ')']
- eq_alts _ _ = False -- catch-all
+ ppr (UfLam b body)
+ = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
- eq_deflt UfCoNoDefault UfCoNoDefault = True
- eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2)
- = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
- eq_deflt _ _ = False
+ ppr (UfApp fun (UfTyArg ty))
+ = hsep [ppr fun, char '@', pprParendHsType ty]
-eqUfExpr (UfLet (UfCoNonRec b1 rhs1) body1) (UfLet (UfCoNonRec b2 rhs2) body2)
- = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2
+ ppr (UfApp fun (UfLitArg lit))
+ = hsep [ppr fun, ppr lit]
-eqUfExpr (UfLet (UfCoRec pairs1) body1) (UfLet (UfCoRec pairs2) body2)
- = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2
- where
- eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
+ ppr (UfApp fun (UfVarArg var))
+ = hsep [ppr fun, ppr var]
-eqUfExpr (UfSCC cc1 body1) (UfSCC cc2 body2)
- = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2)
+ ppr (UfCase scrut alts)
+ = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
+ where
+ pp_alts (UfAlgAlts alts deflt)
+ = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
+ where
+ pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
+ pp_alts (UfPrimAlts alts deflt)
+ = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
+ where
+ pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
-eqUfExpr _ _ = False -- Catch-all
-\end{code}
+ pp_deflt UfNoDefault = empty
+ pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
-\begin{code}
-eqUfId (BoringUfId n1) (BoringUfId n2)
- = eq_name n1 n2
-eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2)
- = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ******
- where
- eq_tycon = panic "HsCore:eqUfId:eq_tycon:ToDo"
-{- LATER:
- eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2)
- = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False }
- eq_tycon ty1 ty2
- = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else
--}
-
-eqUfId (ConstMethodUfId a1 b1 t1) (ConstMethodUfId a2 b2 t2)
- = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2
-eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2)
- = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2
- where
- eq_ty_maybe = panic "HsCore:eqUfId:eq_ty_maybe:ToDo"
-{-
- eq_ty_maybe Nothing Nothing = True
- eq_ty_maybe (Just ty1) (Just ty2)
- = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2)
- -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02]
- eq_ty_maybe _ _ = False
--}
-eqUfId (WorkerUfId id1) (WorkerUfId id2)
- = eqUfId id1 id2
-eqUfId _ _ = False -- catch-all
-\end{code}
+ ppr_arrow = ptext SLIT("->")
-\begin{code}
-eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2
-eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2
-eq_atom _ _ = False
+ 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]
-eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2
+ ppr (UfSCC uf_cc body)
+ = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body]
-eq_name :: ProtoName -> ProtoName -> Bool
-eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names
+instance Outputable name => Outputable (UfPrimOp name) where
+ ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
+ = let
+ before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
+ after = if is_casm then text "'' " else space
+ in
+ hcat [before, ptext str, after,
+ brackets (ppr arg_tys), space, ppr result_ty]
-eq_type ty1 ty2
- = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False }
-\end{code}
+ ppr (UfOtherOp op)
+ = ppr op
-\begin{code}
-eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool
+instance Outputable name => Outputable (UfArg name) where
+ ppr (UfVarArg v) = ppr v
+ ppr (UfLitArg l) = ppr l
+ ppr (UfTyArg ty) = pprParendHsType ty
-eq_lists eq [] [] = True
-eq_lists eq [] _ = False
-eq_lists eq _ [] = False
-eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys
+instance Outputable name => Outputable (UfBinder name) where
+ ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
+ ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
\end{code}
+
projects / ghc-hetmet.git / blobdiff