From: simonpj Date: Thu, 9 Oct 2003 14:31:05 +0000 (+0000) Subject: [project @ 2003-10-09 14:31:05 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~381 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f46d760fc7e69a450503e3256dd9475982fd3be9;p=ghc-hetmet.git [project @ 2003-10-09 14:31:05 by simonpj] Forgot to remove HsCore (now IfaceSyn) --- diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs deleted file mode 100644 index cc0c27b..0000000 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ /dev/null @@ -1,392 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -%************************************************************************ -%* * -\section[HsCore]{Core-syntax unfoldings in Haskell interface files} -%* * -%************************************************************************ - -We could either use this, or parameterise @GenCoreExpr@ on @Types@ and -@TyVars@ as well. Currently trying the former... MEGA SIGH. - -\begin{code} -module HsCore ( - UfExpr(..), UfAlt, UfBinder(..), UfNote(..), - UfBinding(..), UfConAlt(..), - HsIdInfo(..), pprHsIdInfo, - - eq_ufExpr, eq_ufBinders, pprUfExpr, - - toUfExpr, toUfBndr, ufBinderName - ) where - -#include "HsVersions.h" - --- friends: -import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, - HsTupCon(..), EqHsEnv, hsTupParens, - emptyEqHsEnv, extendEqHsEnv, - eq_hsType, eq_hsVars - ) - --- others: -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 ) -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} - -%************************************************************************ -%* * -\subsection[HsCore-types]{Types for read/written Core unfoldings} -%* * -%************************************************************************ - -\begin{code} -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 - | 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 - -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{Converting from Core to UfCore} -%* * -%************************************************************************ - -\begin{code} -toUfExpr :: CoreExpr -> UfExpr Name -toUfExpr (Var v) = toUfVar v -toUfExpr (Lit l) = 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) = 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 - val_args = dropWhile isTypeArg as - saturated = val_args `lengthIs` 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 isFCallId_maybe v of - -- Foreign calls have special syntax - Just fcall -> UfFCall fcall (toHsType (idType v)) - other -> UfVar (getName v) -\end{code} - - -%************************************************************************ -%* * -\subsection[HsCore-print]{Printing Core unfoldings} -%* * -%************************************************************************ - -\begin{code} -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 (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 - - ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi - -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]) - -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 - -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 - 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") - 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 (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} - - -%************************************************************************ -%* * -\subsection[HsCore-print]{Equality, for interface file checking -%* * -%************************************************************************ - - ---------------------------------------- - 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 (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 (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_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 (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 _ _ = False -\end{code} - - -%************************************************************************ -%* * -\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} -