X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=27b6ae606c5dedb39721fc0e247e60116e7408c5;hp=8a02b6d5896320c5f6729925b7ab192a22b103b2;hb=3c36d064aa4b141f6a17574253d97363967a8fe8;hpb=33d4a6bdb9a9b267464459aa049a25f4542305f1 diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 8a02b6d..27b6ae6 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -15,40 +15,41 @@ module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfBinding(..), UfConAlt(..), HsIdInfo(..), pprHsIdInfo, + + eq_ufExpr, eq_ufBinders, pprUfExpr, - eq_ufExpr, eq_ufBinders, pprUfExpr, - - toUfExpr, toUfBndr + toUfExpr, toUfBndr, ufBinderName ) where #include "HsVersions.h" -- friends: import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, - HsTupCon(..), hsTupParens, - emptyEqHsEnv, extendEqHsEnv, eqListBy, - eq_hsType, eq_hsVar, eq_hsVars + HsTupCon(..), EqHsEnv, hsTupParens, + emptyEqHsEnv, extendEqHsEnv, + eq_hsType, eq_hsVars ) -- others: -import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe ) +import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe ) import Var ( varType, isId ) -import IdInfo ( ArityInfo, InlinePragInfo, - pprInlinePragInfo, ppArityInfo, ppStrictnessInfo - ) -import Name ( Name, getName ) +import IdInfo ( InlinePragInfo ) +import Name ( Name, NamedThing(..), eqNameByOcc ) +import RdrName ( RdrName, rdrNameOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) -import PrimOp ( PrimOp(CCallOp) ) -import Demand ( StrictnessInfo ) +import NewDemand ( StrictSig, pprIfaceStrictSig ) import Literal ( Literal, maybeLitLit ) -import PrimOp ( CCall, pprCCallOp ) -import DataCon ( dataConTyCon ) +import ForeignCall ( ForeignCall ) +import DataCon ( dataConTyCon, dataConSourceArity ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) -import Type ( Kind ) +import Type ( Kind, eqKind ) +import BasicTypes ( Arity ) +import FiniteMap ( lookupFM ) import CostCentre -import SrcLoc ( SrcLoc ) +import Util ( eqListBy, lengthIs ) import Outputable +import FastString \end{code} %************************************************************************ @@ -61,28 +62,29 @@ import Outputable data UfExpr name = UfVar name | UfType (HsType name) - | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted + | 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 - | UfLitLit FAST_STRING (HsType name) - | UfCCall CCall (HsType 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 name) + | UfTupleAlt HsTupCon | UfLitAlt Literal - | UfLitLitAlt FAST_STRING (HsType name) + | UfLitLitAlt FastString (HsType name) data UfBinding name = UfNonRec (UfBinder name) @@ -92,6 +94,10 @@ data UfBinding 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} @@ -119,6 +125,7 @@ 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) @@ -128,7 +135,7 @@ 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 (HsTupCon (getName dc) (tupleTyConBoxity tc)) +toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc) | otherwise = UfDataAlt (getName dc) where tc = dataConTyCon dc @@ -139,18 +146,22 @@ toUfCon (LitAlt l) = case maybeLitLit l of 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 isDataConId_maybe v of + = case isDataConWorkId_maybe v of -- We convert the *worker* for tuples into UfTuples - Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args + Just dc | isTupleTyCon tc && saturated + -> UfTuple (mk_hs_tup_con tc dc) tup_args where val_args = dropWhile isTypeArg as - saturated = length val_args == idArity v + saturated = val_args `lengthIs` idArity v tup_args = map toUfExpr val_args tc = dataConTyCon dc ; @@ -162,10 +173,10 @@ toUfApp e as = mkUfApps (toUfExpr e) as mkUfApps = foldl (\f a -> UfApp f (toUfExpr a)) --------------------- -toUfVar v = case isPrimOpId_maybe v of - -- Ccalls has special syntax - Just (CCallOp cc) -> UfCCall cc (toHsType (idType v)) - other -> UfVar (getName v) +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} @@ -176,26 +187,34 @@ toUfVar v = case isPrimOpId_maybe v of %************************************************************************ \begin{code} -instance Outputable name => Outputable (UfExpr name) where +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 :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc +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 (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr 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 ppr bndrs) +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 (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg) +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) @@ -203,13 +222,13 @@ pprUfExpr add_par (UfCase scrut bndr alts) 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 <+> interppSP bs <+> ppr_rhs rhs + pp_alt (c, bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi pprUfExpr add_par (UfLet (UfNonRec b rhs) body) = add_par (hsep [ptext SLIT("let"), - braces (ppr b <+> equals <+> pprUfExpr noParens rhs), + braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs), ptext SLIT("in"), pprUfExpr noParens body]) pprUfExpr add_par (UfLet (UfRec pairs) body) @@ -220,6 +239,9 @@ pprUfExpr add_par (UfLet (UfRec pairs) body) pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body) +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 @@ -232,6 +254,7 @@ instance Outputable name => Outputable (UfNote name) where 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" @@ -242,6 +265,10 @@ instance Outputable name => Outputable (UfConAlt name) where 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} @@ -251,15 +278,33 @@ instance Outputable name => Outputable (UfBinder name) where %* * %************************************************************************ + ---------------------------------------- + HACK ALERT + ---------------------------------------- + +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. + + The hack shows up in eq_ufVar + There are corresponding getOccName calls in MkIface.diffDecls + + ---------------------------------------- + END OF HACK ALERT + ---------------------------------------- + + \begin{code} -instance Ord name => Eq (UfExpr name) where +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==k2 && k (extendEqHsEnv env n1 n2) + = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2) eq_ufBinder _ _ _ _ = False ----------------- @@ -268,10 +313,21 @@ eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinde eq_ufBinders env _ _ _ = False ----------------- -eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2 +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 (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && 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) @@ -300,6 +356,7 @@ eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2) 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 @@ -321,26 +378,25 @@ eq_ufConAlt env _ _ = False %************************************************************************ \begin{code} +pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc pprHsIdInfo [] = empty -pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}") +pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}") data HsIdInfo name - = HsArity ArityInfo - | HsStrictness StrictnessInfo + = HsArity Arity + | HsStrictness StrictSig | HsUnfold InlinePragInfo (UfExpr name) | HsNoCafRefs - | HsCprInfo - | HsWorker name -- Worker, if any + | 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. -instance Outputable name => Outputable (HsIdInfo name) where - ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf) - ppr (HsArity arity) = ppArityInfo arity - ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str - ppr HsNoCafRefs = ptext SLIT("__C") - ppr HsCprInfo = ptext SLIT("__M") - ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w +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}