[project @ 2001-06-25 08:09:57 by simonpj]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsCore.lhs

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 1b377cb..dd1d718 100644 (file)
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -31,23 +31,20 @@ import HsTypes              ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
                        )
 
 -- others:
-import Id              ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
+import Id              ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
 import Var             ( varType, isId )
-import IdInfo          ( ArityInfo, InlinePragInfo, 
-                         pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
-                       )
+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          ( StrictnessInfo )
 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
@@ -72,7 +69,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)
@@ -173,10 +170,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}
 
 
@@ -208,7 +205,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)
@@ -303,7 +300,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
 
 -----------------
@@ -325,7 +322,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)