X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=3212202ce07d8d4a168f564f88237f4135bd96ec;hb=b8b6d871386ce70c5bf54f3bd91efa2dc7364eb7;hp=996c4e89be055fa57206feab64100056b65a372d;hpb=c8208e89a8b71bf761cdf10b3416f0c1150b4f59;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 996c4e8..3212202 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -26,29 +26,29 @@ module HsCore (
 -- friends:
 import HsTypes		( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
 			  HsTupCon(..), EqHsEnv, hsTupParens,
-			  emptyEqHsEnv, extendEqHsEnv, eqListBy, 
+			  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		( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo )
+import IdInfo		( InlinePragInfo, pprInlinePragInfo )
 import Name		( Name, NamedThing(..), getName, toRdrName )
 import RdrName		( RdrName, rdrNameOcc )
 import OccName		( isTvOcc )
 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 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 Util		( eqListBy )
 import Outputable
 \end{code}
 
@@ -70,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)
@@ -171,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 (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}
 
 
@@ -206,7 +206,7 @@ pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name
 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)
@@ -301,7 +301,7 @@ instance (NamedThing name, Ord name) => Eq (UfExpr name) where
 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
 
 -----------------
@@ -323,7 +323,7 @@ eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExp
 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)
@@ -379,10 +379,9 @@ pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext
 
 data HsIdInfo name
   = HsArity		Arity
-  | HsStrictness	StrictnessInfo
+  | HsStrictness	StrictSig
   | HsUnfold		InlinePragInfo (UfExpr name)
   | HsNoCafRefs
-  | HsCprInfo
   | HsWorker		name Arity	-- Worker, if any see IdInfo.WorkerInfo
 					-- for why we want arity here.
   deriving( Eq )
@@ -391,9 +390,8 @@ data HsIdInfo name
 
 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 (HsStrictness str)  = ptext SLIT("__S") <+> pprIfaceStrictSig 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}