X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=83dbd8b1352f03f387adabe272147c21a0a975e6;hb=4a1b418e39175d1ee3482a309eb691ce29dc3199;hp=c7f3c2fe4a58900eccc3939c63bc69a0c8b083e6;hpb=2e41c78179913c2763403bbe7dd1697abf8da791;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index c7f3c2f..83dbd8b 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -14,43 +14,41 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
 module HsCore (
 	UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
 	UfBinding(..), UfConAlt(..),
-	HsIdInfo(..), 
-	IfaceSig(..),
+	HsIdInfo(..), pprHsIdInfo, 
 
-	eq_ufExpr, eq_ufBinders, pprUfExpr,
+	eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
 
-	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, isDataConId_maybe, isFCallId_maybe )
 import Var		( varType, isId )
-import IdInfo		( ArityInfo, UpdateInfo, InlinePragInfo, 
-			  pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
-			)
-import RdrName		( RdrName )
-import Name		( Name, toRdrName )
+import IdInfo		( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo )
+import Name		( Name, NamedThing(..), getName, toRdrName )
+import RdrName		( RdrName, rdrNameOcc )
+import OccName		( isTvOcc )
 import CoreSyn
 import CostCentre	( pprCostCentreCore )
-import PrimOp		( PrimOp(CCallOp) )
-import Demand		( Demand, StrictnessInfo )
+import Demand		( StrictnessInfo )
 import Literal		( Literal, maybeLitLit )
-import PrimOp		( CCall, pprCCallOp )
-import DataCon		( dataConTyCon )
+import ForeignCall	( ForeignCall )
+import DataCon		( dataConTyCon, dataConSourceArity )
 import TyCon		( isTupleTyCon, tupleTyConBoxity )
-import Type		( Type, Kind )
-import CostCentre
-import SrcLoc		( SrcLoc )
+import Type		( Kind, eqKind )
 import BasicTypes	( Arity )
+import FiniteMap	( lookupFM )
+import CostCentre
+import Util		( eqListBy )
 import Outputable
 \end{code}
 
@@ -72,7 +70,7 @@ data UfExpr name
   | UfNote	(UfNote name) (UfExpr name)
   | UfLit	Literal
   | UfLitLit	FAST_STRING (HsType name)
-  | UfCCall	CCall (HsType name)
+  | UfFCall	ForeignCall (HsType name)
 
 data UfNote name = UfSCC CostCentre
 	         | UfCoerce (HsType name)
@@ -95,6 +93,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}
 
 
@@ -105,7 +107,7 @@ data UfBinder name
 %************************************************************************
 
 \begin{code}
-toUfExpr :: CoreExpr -> UfExpr RdrName
+toUfExpr :: CoreExpr -> UfExpr Name
 toUfExpr (Var v) = toUfVar v
 toUfExpr (Lit l) = case maybeLitLit l of
 			Just (s,ty) -> UfLitLit s (toHsType ty)
@@ -113,7 +115,7 @@ toUfExpr (Lit l) = case maybeLitLit l of
 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 (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)
 
@@ -128,11 +130,11 @@ 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)
+toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
 
 ---------------------
-toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc))
-		     | otherwise       = UfDataAlt (toRdrName dc)
+toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
+		     | otherwise       = UfDataAlt (getName dc)
 		     where
 		       tc = dataConTyCon dc
 
@@ -142,15 +144,19 @@ toUfCon (LitAlt l)   = case maybeLitLit l of
 toUfCon DEFAULT	     = UfDefault
 
 ---------------------
-toUfBndr x | isId x    = UfValBinder (toRdrName x) (toHsType (varType x))
-	   | otherwise = UfTyBinder  (toRdrName x) (varType x)
+mk_hs_tup_con tc dc = HsTupCon (getName dc) (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
 	-- We convert the *worker* for tuples into UfTuples
-	Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName 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
@@ -165,10 +171,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 (toRdrName 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}
 
 
@@ -179,23 +185,34 @@ toUfVar v = case isPrimOpId_maybe v of
 %************************************************************************
 
 \begin{code}
-instance Outputable name => Outputable (UfExpr name) where
+instance (NamedThing name, Outputable 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 :: (NamedThing name, Outputable 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"), pprFSAsString l, pprParendHsType ty])
-pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
+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 (UfLam b body)  = add_par (hsep [char '\\', ppr b, ptext SLIT("->"), pprUfExpr noParens body])
-pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens 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 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,10 +220,14 @@ 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 pp_bndr 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), 
@@ -220,6 +241,16 @@ 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
+  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
@@ -229,7 +260,7 @@ instance Outputable name => Outputable (UfNote name) where
 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 (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
     ppr (UfDataAlt d)	   = ppr d
 
 instance Outputable name => Outputable (UfBinder name) where
@@ -244,15 +275,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
 
 -----------------
@@ -261,10 +310,20 @@ 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 -> toRdrName n1 == toRdrName n2
+		       Nothing -> toRdrName n1 == toRdrName 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)
@@ -309,49 +368,32 @@ eq_ufConAlt env _ _ = False
 
 %************************************************************************
 %*									*
-\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 :: (NamedThing n, Outputable 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
+  = HsArity		Arity
   | HsStrictness	StrictnessInfo
   | HsUnfold		InlinePragInfo (UfExpr name)
-  | HsUpdate		UpdateInfo
   | 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") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf)
+ppr_hs_info (HsArity arity)     = ptext SLIT("__A") <+> int arity
+ppr_hs_info (HsStrictness str)  = ptext SLIT("__S") <+> ppStrictnessInfo str
+ppr_hs_info HsNoCafRefs		= ptext SLIT("__C")
+ppr_hs_info HsCprInfo		= ptext SLIT("__M")
+ppr_hs_info (HsWorker w a)	= ptext SLIT("__P") <+> ppr w <+> int a
 \end{code}