X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=27b6ae606c5dedb39721fc0e247e60116e7408c5;hb=49bff3215bf3fe9ada24dac2cf80f97db4e597dd;hp=08bce62fbd49b3a25a0932060b1dfbb96935c87f;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 08bce62..27b6ae6 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % %************************************************************************ %* * @@ -8,34 +8,48 @@ %************************************************************************ 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(..), UfAlt, UfBinder(..), UfNote(..), + UfBinding(..), UfConAlt(..), + HsIdInfo(..), pprHsIdInfo, + + eq_ufExpr, eq_ufBinders, pprUfExpr, + + toUfExpr, toUfBndr, ufBinderName ) where -import Ubiq{-uitous-} +#include "HsVersions.h" -- friends: -import HsTypes ( cmpPolyType, MonoType(..), PolyType(..) ) -import PrimOp ( PrimOp, tagOf_PrimOp ) +import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, + HsTupCon(..), EqHsEnv, hsTupParens, + emptyEqHsEnv, extendEqHsEnv, + eq_hsType, eq_hsVars + ) -- others: -import Literal ( Literal ) -import Outputable ( Outputable(..) {-instances-} ) -import Pretty -import ProtoName ( cmpProtoName, eqProtoName, ProtoName ) -import Util ( panic ) +import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe ) +import Var ( varType, isId ) +import IdInfo ( InlinePragInfo ) +import Name ( Name, NamedThing(..), eqNameByOcc ) +import RdrName ( RdrName, rdrNameOcc ) +import CoreSyn +import CostCentre ( pprCostCentreCore ) +import NewDemand ( StrictSig, pprIfaceStrictSig ) +import Literal ( Literal, maybeLitLit ) +import ForeignCall ( ForeignCall ) +import DataCon ( dataConTyCon, dataConSourceArity ) +import TyCon ( isTupleTyCon, tupleTyConBoxity ) +import Type ( Kind, eqKind ) +import BasicTypes ( Arity ) +import FiniteMap ( lookupFM ) +import CostCentre +import Util ( eqListBy, lengthIs ) +import Outputable +import FastString \end{code} %************************************************************************ @@ -45,298 +59,344 @@ import Util ( panic ) %************************************************************************ \begin{code} -data UnfoldingCoreExpr name - = UfVar (UfId name) +data UfExpr name + = UfVar name + | UfType (HsType name) + | UfTuple HsTupCon [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) | 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 + | UfLitLit FastString (HsType name) + | UfFCall ForeignCall (HsType name) + +data UfNote name = UfSCC CostCentre + | UfCoerce (HsType name) + | UfInlineCall + | UfInlineMe + | UfCoreNote String + +type UfAlt name = (UfConAlt name, [name], UfExpr name) + +data UfConAlt name = UfDefault + | UfDataAlt name + | UfTupleAlt HsTupCon + | UfLitAlt Literal + | UfLitLitAlt FastString (HsType name) + +data UfBinding name + = UfNonRec (UfBinder name) + (UfExpr name) + | UfRec [(UfBinder name, UfExpr name)] + +data UfBinder name + = UfValBinder name (HsType name) + | UfTyBinder name Kind + +ufBinderName :: UfBinder name -> name +ufBinderName (UfValBinder n _) = n +ufBinderName (UfTyBinder n _) = n \end{code} + %************************************************************************ %* * -\subsection[HsCore-print]{Printing Core unfoldings} +\subsection{Converting from Core to UfCore} %* * %************************************************************************ \begin{code} -instance Outputable name => Outputable (UnfoldingCoreExpr name) where - ppr sty (UfVar v) = pprUfId sty v - ppr sty (UfLit l) = ppr sty l - - 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 sty (UfLam bs body) - = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body] - - ppr sty (UfApp fun arg) - = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"] - - 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] +toUfExpr :: CoreExpr -> UfExpr Name +toUfExpr (Var v) = toUfVar v +toUfExpr (Lit l) = case maybeLitLit l of + Just (s,ty) -> UfLitLit s (toHsType ty) + Nothing -> UfLit l +toUfExpr (Type ty) = UfType (toHsType ty) +toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b) +toUfExpr (App f a) = toUfApp f [a] +toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as) +toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e) +toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e) + +--------------------- +toUfNote (SCC cc) = UfSCC cc +toUfNote (Coerce t1 _) = UfCoerce (toHsType t1) +toUfNote InlineCall = UfInlineCall +toUfNote InlineMe = UfInlineMe +toUfNote (CoreNote s) = UfCoreNote s + +--------------------- +toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r) +toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs] + +--------------------- +toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r) + +--------------------- +toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc) + | otherwise = UfDataAlt (getName dc) + where + tc = dataConTyCon dc + +toUfCon (LitAlt l) = case maybeLitLit l of + Just (s,ty) -> UfLitLitAlt s (toHsType ty) + Nothing -> UfLitAlt l +toUfCon DEFAULT = UfDefault + +--------------------- +mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc) + +--------------------- +toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x)) + | otherwise = UfTyBinder (getName x) (varType x) + +--------------------- +toUfApp (App f a) as = toUfApp f (a:as) +toUfApp (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into UfTuples + Just dc | isTupleTyCon tc && saturated + -> UfTuple (mk_hs_tup_con tc dc) tup_args where - pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs] + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map toUfExpr val_args + tc = dataConTyCon dc + ; - pp_deflt UfCoNoDefault = ppNil - pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs] + other -> mkUfApps (toUfVar v) as - 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_ ", 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 +toUfApp e as = mkUfApps (toUfExpr e) as + +mkUfApps = foldl (\f a -> UfApp f (toUfExpr a)) -pprUfId sty (WorkerUfId unwrkr) - = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"] +--------------------- +toUfVar v = case isFCallId_maybe v of + -- Foreign calls have special syntax + Just fcall -> UfFCall fcall (toHsType (idType v)) + other -> UfVar (getName v) \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 +instance OutputableBndr name => Outputable (UfExpr name) where + ppr e = pprUfExpr noParens e + + +-- Small-hack alert: this instance allows us to do a getOccName on RdrNames. +-- Important because we want to pretty-print UfExprs, and we have to +-- print an '@' before tyvar-binders in a case alternative. +instance NamedThing RdrName where + getOccName n = rdrNameOcc n + getName n = pprPanic "instance NamedThing RdrName" (ppr n) + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +pprUfExpr add_par (UfVar v) = ppr v +pprUfExpr add_par (UfLit l) = ppr l +pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty]) +pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty) +pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty + +pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs) + <+> ptext SLIT("->") <+> pprUfExpr noParens body) + where (bndrs,body) = collectUfBndrs e +pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app) +pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as) + +pprUfExpr add_par (UfCase scrut bndr alts) + = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr, + braces (hsep (map pp_alt alts))]) + where + pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs + pp_alt (c, bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs -eqUfExpr (UfVar v1) (UfVar v2) = eqUfId v1 v2 -eqUfExpr (UfLit l1) (UfLit l2) = l1 == l2 + ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi -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 +pprUfExpr add_par (UfLet (UfNonRec b rhs) body) + = add_par (hsep [ptext SLIT("let"), + braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs), + ptext SLIT("in"), pprUfExpr noParens body]) -eqUfExpr (UfLam bs1 body1) (UfLam bs2 body2) - = eq_binder bs1 bs2 && eqUfExpr body1 body2 +pprUfExpr add_par (UfLet (UfRec pairs) body) + = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)), + ptext SLIT("in"), pprUfExpr noParens body]) + where + pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi -eqUfExpr (UfApp fun1 arg1) (UfApp fun2 arg2) - = eqUfExpr fun1 fun2 && eq_atom arg1 arg2 +pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body) -eqUfExpr (UfCase scrut1 alts1) (UfCase scrut2 alts2) - = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2 +pprUfApp (UfApp fun arg) = pprUfApp fun <+> pprUfExpr parens arg +pprUfApp fun = pprUfExpr parens fun + +collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name) +collectUfBndrs expr + = go [] expr 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 + go bs (UfLam b e) = go (b:bs) e + go bs e = (reverse bs, e) + +instance Outputable name => Outputable (UfNote name) where + ppr (UfSCC cc) = pprCostCentreCore cc + ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty + ppr UfInlineCall = ptext SLIT("__inline_call") + ppr UfInlineMe = ptext SLIT("__inline_me") + ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s) + +instance Outputable name => Outputable (UfConAlt name) where + ppr UfDefault = text "__DEFAULT" + ppr (UfLitAlt l) = ppr l + ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty]) + ppr (UfDataAlt d) = ppr d + +instance Outputable name => Outputable (UfBinder name) where + ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty] + ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind + +instance OutputableBndr name => OutputableBndr (UfBinder name) where + pprBndr _ (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty] + pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind +\end{code} - 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 - eq_alts _ _ = False -- catch-all +%************************************************************************ +%* * +\subsection[HsCore-print]{Equality, for interface file checking +%* * +%************************************************************************ - eq_deflt UfCoNoDefault UfCoNoDefault = True - eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2) - = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 - eq_deflt _ _ = False + ---------------------------------------- + HACK ALERT + ---------------------------------------- -eqUfExpr (UfLet (UfCoNonRec b1 rhs1) body1) (UfLet (UfCoNonRec b2 rhs2) body2) - = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2 +Whe comparing UfExprs, we compare names by converting to RdrNames and comparing +those. Reason: this is used when comparing ufoldings in interface files, and the +uniques can differ. Converting to RdrNames makes it more like comparing the file +contents directly. But this is bad: version numbers can change when only alpha-conversion +has happened. -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 + The hack shows up in eq_ufVar + There are corresponding getOccName calls in MkIface.diffDecls -eqUfExpr (UfSCC cc1 body1) (UfSCC cc2 body2) - = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2) + ---------------------------------------- + END OF HACK ALERT + ---------------------------------------- -eqUfExpr _ _ = False -- Catch-all -\end{code} \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 +instance (NamedThing name, Ord name) => Eq (UfExpr name) where + (==) a b = eq_ufExpr emptyEqHsEnv a b + +----------------- +eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k + = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2) +eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k + = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2) +eq_ufBinder _ _ _ _ = False + +----------------- +eq_ufBinders env [] [] k = k env +eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k) +eq_ufBinders env _ _ _ = False + +----------------- +eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool +-- Compare *Rdr* names. A real hack to avoid gratuitous +-- differences when comparing interface files +eq_ufVar env n1 n2 = case lookupFM env n1 of + Just n1 -> check n1 + Nothing -> check n1 + where + check n1 = eqNameByOcc (getName n1) (getName n2) + +----------------- +eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool +eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2 +eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2 +eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2 +eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2 +eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2 +eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2 +eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2) +eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2 + +eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2) + = eq_ufExpr env s1 s2 && + eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2 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} - -\begin{code} -eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2 -eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2 -eq_atom _ _ = False + eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2) + = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2) -eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2 +eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2) + = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2) -eq_name :: ProtoName -> ProtoName -> Bool -eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names +eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2) + = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2) + where + (bs1,rs1) = unzip as1 + (bs2,rs2) = unzip as2 -eq_type ty1 ty2 - = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False } +eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2) + = eq_ufNote n1 n2 && eq_ufExpr env r1 r2 + where + eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2 + eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2 + eq_ufNote UfInlineCall UfInlineCall = True + eq_ufNote UfInlineMe UfInlineMe = True + eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2 + eq_ufNote _ _ = False + +eq_ufExpr env _ _ = False + +----------------- +eq_ufConAlt env UfDefault UfDefault = True +eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2 +eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2 +eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2 +eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2 +eq_ufConAlt env _ _ = False \end{code} -\begin{code} -eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool -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 +%************************************************************************ +%* * +\subsection{Rules in interface files} +%* * +%************************************************************************ + +\begin{code} +pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc +pprHsIdInfo [] = empty +pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}") + +data HsIdInfo name + = HsArity Arity + | HsStrictness StrictSig + | HsUnfold InlinePragInfo (UfExpr name) + | HsNoCafRefs + | HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo + -- for why we want arity here. + deriving( Eq ) +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> ppr prag <+> parens (pprUfExpr noParens unf) +ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity +ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> pprIfaceStrictSig str +ppr_hs_info HsNoCafRefs = ptext SLIT("__C") +ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a \end{code} +