X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=fc5d3aee2ec2ef32fc414f0006cd32ac3007fa5f;hb=9af77fa423926fbda946b31e174173d0ec5ebac8;hp=8a13a77058093d7780990bb25b1fe6c14c603597;hpb=4bca2e7f766e3a265e77cbce4884f889d6d28299;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 8a13a77..fc5d3ae 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -44,21 +44,21 @@ module TcType (
   tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
   isSigmaTy, isOverloadedTy, 
   isDoubleTy, isFloatTy, isIntTy,
-  isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy, 
+  isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
   isTauTy, tcIsTyVarTy, tcIsForAllTy,
   allDistinctTyVars,
 
   ---------------------------------
   -- Misc type manipulators
-  deNoteType, 
-  namesOfType, namesOfDFunHead,
+  deNoteType, classNamesOfTheta,
+  tyClsNamesOfType, tyClsNamesOfDFunHead, 
   getDFunTyKey,
 
   ---------------------------------
   -- Predicate types  
-  PredType, getClassPredTys_maybe, getClassPredTys, 
+  getClassPredTys_maybe, getClassPredTys, 
   isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
-  mkDictTy, tcSplitPredTy_maybe, predTyUnique,
+  mkDictTy, tcSplitPredTy_maybe, 
   isDictTy, tcSplitDFunTy, predTyUnique, 
   mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
 
@@ -105,6 +105,7 @@ module TcType (
 
 
 import {-# SOURCE #-} PprType( pprType )
+-- PprType imports TcType so that it can print intelligently
 
 -- friends:
 import TypeRep		( Type(..), TyNote(..), funTyCon )  -- friend
@@ -699,7 +700,6 @@ isOverloadedTy _		   = False
 \begin{code}
 isFloatTy      = is_tc floatTyConKey
 isDoubleTy     = is_tc doubleTyConKey
-isForeignPtrTy = is_tc foreignPtrTyConKey
 isIntegerTy    = is_tc integerTyConKey
 isIntTy        = is_tc intTyConKey
 isAddrTy       = is_tc addrTyConKey
@@ -737,34 +737,38 @@ deNoteSourceType (IParam n ty)    = IParam n (deNoteType ty)
 deNoteSourceType (NType tc tys)   = NType tc (map deNoteType tys)
 \end{code}
 
-Find the free names of a type, including the type constructors and classes it mentions
-This is used in the front end of the compiler
+Find the free tycons and classes of a type.  This is used in the front
+end of the compiler.
 
 \begin{code}
-namesOfType :: Type -> NameSet
-namesOfType (TyVarTy tv)		= unitNameSet (getName tv)
-namesOfType (TyConApp tycon tys)	= unitNameSet (getName tycon) `unionNameSets` namesOfTypes tys
-namesOfType (NoteTy (SynNote ty1) ty2)	= namesOfType ty1
-namesOfType (NoteTy other_note    ty2)	= namesOfType ty2
-namesOfType (SourceTy (IParam n ty))	= namesOfType ty
-namesOfType (SourceTy (ClassP cl tys))	= unitNameSet (getName cl) `unionNameSets` namesOfTypes tys
-namesOfType (SourceTy (NType tc tys))	= unitNameSet (getName tc) `unionNameSets` namesOfTypes tys
-namesOfType (FunTy arg res)		= namesOfType arg `unionNameSets` namesOfType res
-namesOfType (AppTy fun arg)		= namesOfType fun `unionNameSets` namesOfType arg
-namesOfType (ForAllTy tyvar ty)		= namesOfType ty `delFromNameSet` getName tyvar
-
-namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
-
-namesOfDFunHead :: Type -> NameSet
+tyClsNamesOfType :: Type -> NameSet
+tyClsNamesOfType (TyVarTy tv)		    = emptyNameSet
+tyClsNamesOfType (TyConApp tycon tys)	    = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
+tyClsNamesOfType (NoteTy other_note    ty2) = tyClsNamesOfType ty2
+tyClsNamesOfType (SourceTy (IParam n ty))   = tyClsNamesOfType ty
+tyClsNamesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (SourceTy (NType tc tys))  = unitNameSet (getName tc) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (FunTy arg res)	    = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
+tyClsNamesOfType (AppTy fun arg)	    = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
+tyClsNamesOfType (ForAllTy tyvar ty)	    = tyClsNamesOfType ty
+
+tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
+
+tyClsNamesOfDFunHead :: Type -> NameSet
 -- Find the free type constructors and classes 
 -- of the head of the dfun instance type
 -- The 'dfun_head_type' is because of
 --	instance Foo a => Baz T where ...
 -- The decl is an orphan if Baz and T are both not locally defined,
 --	even if Foo *is* locally defined
-namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of
-				(tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
-								      (map getName tvs)
+tyClsNamesOfDFunHead dfun_ty 
+  = case tcSplitSigmaTy dfun_ty of
+	(tvs,_,head_ty) -> tyClsNamesOfType head_ty
+
+classNamesOfTheta :: ThetaType -> [Name]
+-- Looks just for ClassP things; maybe it should check
+classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ]
 \end{code}
 
 
@@ -830,8 +834,7 @@ legalFEArgTyCon :: TyCon -> Bool
 -- bytearrays from a _ccall_ / foreign declaration
 -- (or be passed them as arguments in foreign exported functions).
 legalFEArgTyCon tc
-  | getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
-			  byteArrayTyConKey, mutableByteArrayTyConKey ] 
+  | getUnique tc `elem` [ byteArrayTyConKey, mutableByteArrayTyConKey ] 
   = False
   -- It's also illegal to make foreign exports that take unboxed
   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
@@ -841,16 +844,14 @@ legalFEArgTyCon tc
 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
 legalFIResultTyCon dflags tc
   | getUnique tc `elem`
-	[ foreignObjTyConKey, foreignPtrTyConKey,
-	  byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
+	[ byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
   | tc == unitTyCon = True
   | otherwise	    = marshalableTyCon dflags tc
 
 legalFEResultTyCon :: TyCon -> Bool
 legalFEResultTyCon tc
   | getUnique tc `elem` 
-	[ foreignObjTyConKey, foreignPtrTyConKey,
-	  byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
+	[ byteArrayTyConKey, mutableByteArrayTyConKey ]  = False
   | tc == unitTyCon = True
   | otherwise       = boxedMarshalableTyCon tc
 
@@ -873,8 +874,7 @@ boxedMarshalableTyCon tc
 			 , word32TyConKey, word64TyConKey
 			 , floatTyConKey, doubleTyConKey
 			 , addrTyConKey, ptrTyConKey, funPtrTyConKey
-			 , charTyConKey, foreignObjTyConKey
-			 , foreignPtrTyConKey
+			 , charTyConKey
 			 , stablePtrTyConKey
 			 , byteArrayTyConKey, mutableByteArrayTyConKey
 			 , boolTyConKey