X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=4124ad83f8d14b93f7bb33e06fb1fac2ac65dc76;hb=525898a970c625753c33490318762c2b4c2770a9;hp=b5d80e80dcdd75277b7b0d3baa48ee15288f46a7;hpb=0fffbea841d9647388a7b845808a9757782da663;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index b5d80e8..4124ad8 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -13,18 +13,44 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and \begin{code} module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), - UfBinding(..), UfCon(..) + UfBinding(..), UfConAlt(..), + HsIdInfo(..), + IfaceSig(..), + + eq_ufExpr, eq_ufBinders, pprUfExpr, + + toUfExpr, toUfBndr ) where #include "HsVersions.h" -- friends: -import HsTypes ( HsType, pprParendHsType ) +import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, + HsTupCon(..), hsTupParens, + emptyEqHsEnv, extendEqHsEnv, eqListBy, + eq_hsType, eq_hsVar, eq_hsVars + ) -- others: -import Const ( Literal ) -import Type ( Kind ) +import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe ) +import Var ( varType, isId ) +import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, + pprInlinePragInfo, ppArityInfo, ppStrictnessInfo + ) +import RdrName ( RdrName ) +import Name ( Name, toRdrName ) +import CoreSyn +import CostCentre ( pprCostCentreCore ) +import PrimOp ( PrimOp(CCallOp) ) +import Demand ( Demand, StrictnessInfo ) +import Literal ( Literal, maybeLitLit ) +import PrimOp ( CCall, pprCCallOp ) +import DataCon ( dataConTyCon ) +import TyCon ( isTupleTyCon, tupleTyConBoxity ) +import Type ( Type, Kind ) import CostCentre +import SrcLoc ( SrcLoc ) +import BasicTypes ( Arity ) import Outputable \end{code} @@ -38,29 +64,28 @@ import Outputable data UfExpr name = UfVar name | UfType (HsType name) - | UfCon (UfCon name) [UfExpr name] - | UfTuple name [UfExpr name] -- Type arguments omitted - | UfLam (UfBinder name) (UfExpr name) - | UfApp (UfExpr name) (UfExpr name) + | UfTuple (HsTupCon name) [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) data UfNote name = UfSCC CostCentre | UfCoerce (HsType name) | UfInlineCall + | UfInlineMe -type UfAlt name = (UfCon name, [name], UfExpr name) +type UfAlt name = (UfConAlt name, [name], UfExpr name) -data UfCon name = UfDefault - | UfDataCon name - | UfLitCon Literal - | UfLitLitCon FAST_STRING (HsType name) - | UfPrimOp name - | UfCCallOp FAST_STRING -- callee - Bool -- True => dynamic (first arg is fun. pointer) - Bool -- True <=> casm, rather than ccall - Bool -- True <=> might cause GC +data UfConAlt name = UfDefault + | UfDataAlt name + | UfTupleAlt (HsTupCon name) + | UfLitAlt Literal + | UfLitLitAlt FAST_STRING (HsType name) data UfBinding name = UfNonRec (UfBinder name) @@ -75,56 +100,268 @@ data UfBinder name %************************************************************************ %* * +\subsection{Converting from Core to UfCore} +%* * +%************************************************************************ + +\begin{code} +toUfExpr :: CoreExpr -> UfExpr RdrName +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) (toRdrName 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 + +--------------------- +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 toRdrName bs, toUfExpr r) + +--------------------- +toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) + | otherwise = UfDataAlt (toRdrName 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 + +--------------------- +toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x)) + | otherwise = UfTyBinder (toRdrName x) (varType x) + +--------------------- +toUfApp (App f a) as = toUfApp f (a:as) +toUfApp (Var v) as + = case isDataConId_maybe v of + -- We convert the *worker* for tuples into UfTuples + Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args + where + val_args = dropWhile isTypeArg as + saturated = length val_args == idArity v + tup_args = map toUfExpr val_args + tc = dataConTyCon dc + ; + + other -> mkUfApps (toUfVar v) as + +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 (toRdrName v) +\end{code} + + +%************************************************************************ +%* * \subsection[HsCore-print]{Printing Core unfoldings} %* * %************************************************************************ \begin{code} instance Outputable name => Outputable (UfExpr name) where - ppr (UfVar v) = ppr v - ppr (UfType ty) = char '@' <+> pprParendHsType ty + ppr e = pprUfExpr noParens e - ppr (UfCon c as) - = hsep [text "UfCon", ppr c, ppr as] +noParens :: SDoc -> SDoc +noParens pp = pp - ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as))) +pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) - ppr (UfLam b body) - = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body] +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"), pprFSAsString l, pprParendHsType ty]) +pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty) +pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty - ppr (UfApp fun arg) = ppr fun <+> ppr arg +pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr 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 (UfTuple c as) = hsTupParens c (interpp'SP as) - ppr (UfCase scrut bndr alts) - = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr, - braces (hsep (punctuate semi (map pp_alt alts)))] +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 (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs] + 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 + + ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi - ppr_arrow = ptext SLIT("->") +pprUfExpr add_par (UfLet (UfNonRec b rhs) body) + = add_par (hsep [ptext SLIT("let"), + braces (ppr b <+> equals <+> pprUfExpr noParens rhs), + ptext SLIT("in"), pprUfExpr noParens body]) - 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] +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) = hsep [ppr b, equals, ppr rhs] + pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi - ppr (UfNote note body) - = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body] +pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body) -instance Outputable name => Outputable (UfCon name) where - ppr UfDefault = text "DEFAULT" - ppr (UfDataCon d) = ppr d - ppr (UfPrimOp p) = ppr p - ppr (UfCCallOp str is_dyn is_casm can_gc) - = hcat [before, ptext str, after] - where - before = (if is_dyn then ptext SLIT("_dyn_") else empty) <> - ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ ")) - after = if is_casm then text "'' " else space +collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name) +collectUfBndrs expr + = go [] expr + where + 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") + +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"), pprFSAsString l, pprParendHsType ty]) + ppr (UfDataAlt d) = ppr d instance Outputable name => Outputable (UfBinder name) where - ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty] - ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind] + ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty] + ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind +\end{code} + + +%************************************************************************ +%* * +\subsection[HsCore-print]{Equality, for interface file checking +%* * +%************************************************************************ + +\begin{code} +instance 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) +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_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar 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 (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_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_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_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_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 _ _ = 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} + + +%************************************************************************ +%* * +\subsection{Signatures in interface files} +%* * +%************************************************************************ + +\begin{code} +data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc + +instance Ord name => Eq (IfaceSig name) where + (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2 + +instance (Outputable name) => Outputable (IfaceSig name) where + ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] +\end{code} + + +%************************************************************************ +%* * +\subsection{Rules in interface files} +%* * +%************************************************************************ + +\begin{code} +pprHsIdInfo [] = empty +pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}") + +data HsIdInfo name + = HsArity ArityInfo + | HsStrictness StrictnessInfo + | HsUnfold InlinePragInfo (UfExpr name) + | HsUpdate UpdateInfo + | HsNoCafRefs + | HsCprInfo + | HsWorker name -- Worker, if any + 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 \end{code}