remove more Addr bits

[ghc-hetmet.git] / compiler / typecheck / TcType.lhs

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 4b6e7b8..b60936d 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -52,7 +52,7 @@ module TcType (
   tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
   isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
   isDoubleTy, isFloatTy, isIntTy, isStringTy,
-  isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
+  isIntegerTy, isBoolTy, isUnitTy,
   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, 
 
   ---------------------------------
@@ -82,13 +82,14 @@ module TcType (
   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
   isFFIDotnetObjTy,    -- :: Type -> Bool
   isFFITy,            -- :: Type -> Bool
-  
+  tcSplitIOType_maybe, -- :: Type -> Maybe Type  
   toDNType,            -- :: Type -> DNType
 
   --------------------------------
   -- Rexported from Type
   Kind,        -- Stuff to do with kinds is insensitive to pre/post Tc
-  unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, 
+  unliftedTypeKind, liftedTypeKind, unboxedTypeKind,
+  openTypeKind, mkArrowKind, mkArrowKinds, 
   isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, 
   isArgTypeKind, isSubKind, defaultKind, 
 
@@ -131,7 +132,7 @@ import TypeRep              ( Type(..), funTyCon )  -- friend
 import Type            (       -- Re-exports
                          tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
                          tyVarsOfTheta, Kind, PredType(..),
-                         ThetaType, unliftedTypeKind, 
+                         ThetaType, unliftedTypeKind, unboxedTypeKind,
                          liftedTypeKind, openTypeKind, mkArrowKind,
                          isLiftedTypeKind, isUnliftedTypeKind, 
                          mkArrowKinds, mkForAllTy, mkForAllTys,
@@ -160,7 +161,7 @@ import Type         (       -- Re-exports
                          substTy, substTys, substTyWith, substTheta, 
                          substTyVar, substTyVarBndr, substPred, lookupTyVar,
 
-                         typeKind, repType,
+                         typeKind, repType, coreView,
                          pprKind, pprParendKind,
                          pprType, pprParendType, pprTyThingCategory,
                          pprPred, pprTheta, pprThetaArrow, pprClassPred
@@ -813,8 +814,8 @@ mkDictTy clas tys = mkPredTy (ClassP clas tys)
 
 isDictTy :: Type -> Bool
 isDictTy ty | Just ty' <- tcView ty = isDictTy ty'
-isDictTy (PredTy p)   = isClassPred p
-isDictTy other         = False
+isDictTy (PredTy p) = isClassPred p
+isDictTy other     = False
 \end{code}
 
 --------------------- Implicit parameters ---------------------------------
@@ -898,7 +899,6 @@ isFloatTy      = is_tc floatTyConKey
 isDoubleTy     = is_tc doubleTyConKey
 isIntegerTy    = is_tc integerTyConKey
 isIntTy        = is_tc intTyConKey
-isAddrTy       = is_tc addrTyConKey
 isBoolTy       = is_tc boolTyConKey
 isUnitTy       = is_tc unitTyConKey
 
@@ -1029,6 +1029,23 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
+-- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or
+--                                    some newtype wrapping thereof
+--             returns Nothing otherwise
+tcSplitIOType_maybe ty 
+  | Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty,
+       -- This split absolutely has to be a tcSplit, because we must
+       -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
+    io_tycon `hasKey` ioTyConKey
+  = Just (io_tycon, io_res_ty)
+
+  | Just ty' <- coreView ty    -- Look through non-recursive newtypes
+  = tcSplitIOType_maybe ty'
+
+  | otherwise
+  = Nothing
+
 isFFITy :: Type -> Bool
 -- True for any TyCon that can possibly be an arg or result of an FFI call
 isFFITy ty = checkRepTyCon legalFFITyCon ty
@@ -1052,22 +1069,21 @@ isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
 isFFIDynArgumentTy :: Type -> Bool
 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
 -- or a newtype of either.
-isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
 
 isFFIDynResultTy :: Type -> Bool
 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
 -- or a newtype of either.
-isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
 
 isFFILabelTy :: Type -> Bool
 -- The type of a foreign label must be Ptr, FunPtr, Addr,
 -- or a newtype of either.
-isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
 
 isFFIDotnetTy :: DynFlags -> Type -> Bool
 isFFIDotnetTy dflags ty
-  = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
-                          (legalFIResultTyCon dflags tc || 
+  = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || 
                           isFFIDotnetObjTy ty || isStringTy ty)) ty
 
 -- Support String as an argument or result from a .NET FFI call.
@@ -1114,7 +1130,6 @@ toDNType ty
                 , (word64TyConKey, DNWord64)
                 , (floatTyConKey,  DNFloat)
                 , (doubleTyConKey, DNDouble)
-                , (addrTyConKey,   DNPtr)
                 , (ptrTyConKey,    DNPtr)
                 , (funPtrTyConKey, DNPtr)
                 , (charTyConKey,   DNChar)
@@ -1143,35 +1158,24 @@ These chaps do the work; they are not exported
 
 \begin{code}
 legalFEArgTyCon :: TyCon -> Bool
--- It's illegal to return foreign objects and (mutable)
--- bytearrays from a _ccall_ / foreign declaration
--- (or be passed them as arguments in foreign exported functions).
 legalFEArgTyCon tc
-  | isByteArrayLikeTyCon tc
-  = False
-  -- It's also illegal to make foreign exports that take unboxed
+  -- It's illegal to make foreign exports that take unboxed
   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
-  | otherwise
   = boxedMarshalableTyCon tc
 
 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
 legalFIResultTyCon dflags tc
-  | isByteArrayLikeTyCon tc = False
   | tc == unitTyCon         = True
   | otherwise              = marshalableTyCon dflags tc
 
 legalFEResultTyCon :: TyCon -> Bool
 legalFEResultTyCon tc
-  | isByteArrayLikeTyCon tc = False
   | tc == unitTyCon         = True
   | otherwise               = boxedMarshalableTyCon tc
 
 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
 -- Checks validity of types going from Haskell -> external world
 legalOutgoingTyCon dflags safety tc
-  | playSafe safety && isByteArrayLikeTyCon tc
-  = False
-  | otherwise
   = marshalableTyCon dflags tc
 
 legalFFITyCon :: TyCon -> Bool
@@ -1189,14 +1193,9 @@ boxedMarshalableTyCon tc
                         , wordTyConKey, word8TyConKey, word16TyConKey
                         , word32TyConKey, word64TyConKey
                         , floatTyConKey, doubleTyConKey
-                        , addrTyConKey, ptrTyConKey, funPtrTyConKey
+                        , ptrTyConKey, funPtrTyConKey
                         , charTyConKey
                         , stablePtrTyConKey
-                        , byteArrayTyConKey, mutableByteArrayTyConKey
                         , boolTyConKey
                         ]
-
-isByteArrayLikeTyCon :: TyCon -> Bool
-isByteArrayLikeTyCon tc = 
-  getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
 \end{code}