X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=27b6ae606c5dedb39721fc0e247e60116e7408c5;hp=0f5a02037073941ce3173300eca51ba5d9fc6726;hb=3c36d064aa4b141f6a17574253d97363967a8fe8;hpb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 0f5a020..27b6ae6 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -16,7 +16,7 @@ module HsCore ( UfBinding(..), UfConAlt(..), HsIdInfo(..), pprHsIdInfo, - eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo, + eq_ufExpr, eq_ufBinders, pprUfExpr, toUfExpr, toUfBndr, ufBinderName ) where @@ -31,12 +31,11 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, ) -- others: -import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe ) +import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe ) import Var ( varType, isId ) import IdInfo ( InlinePragInfo ) -import Name ( Name, NamedThing(..), toRdrName ) +import Name ( Name, NamedThing(..), eqNameByOcc ) import RdrName ( RdrName, rdrNameOcc ) -import OccName ( isTvOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) import NewDemand ( StrictSig, pprIfaceStrictSig ) @@ -63,7 +62,7 @@ import FastString 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] @@ -77,12 +76,13 @@ 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 FastString (HsType name) @@ -125,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) @@ -145,7 +146,7 @@ toUfCon (LitAlt l) = case maybeLitLit l of toUfCon DEFAULT = UfDefault --------------------- -mk_hs_tup_con tc dc = HsTupCon (getName dc) (tupleTyConBoxity tc) (dataConSourceArity dc) +mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc) --------------------- toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x)) @@ -154,7 +155,7 @@ toUfBndr x | isId x = UfValBinder (getName x) (toHsType (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 (mk_hs_tup_con tc dc) tup_args @@ -186,7 +187,7 @@ toUfVar v = case isFCallId_maybe v of %************************************************************************ \begin{code} -instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where +instance OutputableBndr name => Outputable (UfExpr name) where ppr e = pprUfExpr noParens e @@ -200,7 +201,7 @@ instance NamedThing RdrName where noParens :: SDoc -> SDoc noParens pp = pp -pprUfExpr :: (NamedThing name, 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) @@ -210,7 +211,7 @@ pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHs 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 app@(UfApp _ _) = add_par (pprUfApp app) @@ -221,17 +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 <+> hsep (map pp_bndr 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 - -- This use of getOccName is the sole reason for the NamedThing in pprUfExpr's type - pp_bndr v | isTvOcc (getOccName v) = char '@' <+> ppr v - | otherwise = ppr v - 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) @@ -257,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" @@ -267,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} @@ -315,9 +317,10 @@ 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 -> toRdrName n1 == toRdrName n2 - Nothing -> toRdrName n1 == toRdrName n2 - + 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 @@ -353,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 @@ -374,7 +378,7 @@ eq_ufConAlt env _ _ = False %************************************************************************ \begin{code} -pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc +pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc pprHsIdInfo [] = empty pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")