[project @ 2001-06-14 12:50:05 by simonpj]

[ghc-hetmet.git] / ghc / compiler / prelude / TysWiredIn.lhs

diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index f67ee06..7e046be 100644 (file)
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -19,6 +19,9 @@ module TysWiredIn (
        ptrDataCon,
        ptrTy,
        ptrTyCon,
+       funPtrDataCon,
+       funPtrTy,
+       funPtrTyCon,
        boolTy,
        boolTyCon,
        charDataCon,
@@ -72,7 +75,7 @@ module TysWiredIn (
        wordTy,
        wordTyCon,
 
-       isFFIArgumentTy,     -- :: DynFlags -> Bool -> Type -> Bool
+       isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
        isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
        isFFIExportResultTy, -- :: Type -> Bool
        isFFIExternalTy,     -- :: Type -> Bool
@@ -94,13 +97,15 @@ import PrelNames
 import TysPrim
 
 -- others:
+import ForeignCall     ( Safety, playSafe )
 import Constants       ( mAX_TUPLE_SIZE )
 import Module          ( mkPrelModule )
 import Name            ( Name, nameRdrName, nameUnique, nameOccName, 
                          nameModule, mkWiredInName )
 import OccName         ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
 import RdrName         ( rdrNameOcc )
-import DataCon         ( DataCon, StrictnessMark(..),  mkDataCon, dataConId )
+import DataCon         ( DataCon, mkDataCon, dataConId )
+import Demand          ( StrictnessMark(..) )
 import Var             ( TyVar, tyVarKind )
 import TyCon           ( TyCon, AlgTyConFlavour(..), tyConDataCons,
                          mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon
@@ -136,6 +141,7 @@ wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons
 data_tycons = genericTyCons ++
              [ addrTyCon
              , ptrTyCon
+             , funPtrTyCon
              , boolTyCon
              , charTyCon
              , doubleTyCon
@@ -150,8 +156,8 @@ genericTyCons :: [TyCon]
 genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ]
 
 
-tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ]
-unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ]
+tuple_tycons = unitTyCon : [tupleTyCon Boxed   i | i <- [2..mAX_TUPLE_SIZE] ]
+unboxed_tuple_tycons     = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ]
 \end{code}
 
 
@@ -344,6 +350,13 @@ ptrDataCon = pcDataCon ptrDataConName alpha_tyvar [] [addrPrimTy] ptrTyCon
 \end{code}
 
 \begin{code}
+funPtrTy = mkTyConTy funPtrTyCon
+
+funPtrTyCon = pcNonRecDataTyCon funPtrTyConName alpha_tyvar [(True,False)] [funPtrDataCon]
+funPtrDataCon = pcDataCon funPtrDataConName alpha_tyvar [] [addrPrimTy] funPtrTyCon
+\end{code}
+
+\begin{code}
 floatTy        = mkTyConTy floatTyCon
 
 floatTyCon   = pcNonRecDataTyCon floatTyConName   [] [] [floatDataCon]
@@ -381,9 +394,6 @@ foreignObjTyCon
     foreignObjDataCon
       = pcDataCon foreignObjDataConName
            [] [] [foreignObjPrimTy] foreignObjTyCon
-
-isForeignObjTy :: Type -> Bool
-isForeignObjTy = isTyCon foreignObjTyConKey
 \end{code}
 
 \begin{code}
@@ -435,10 +445,10 @@ restricted set of types as arguments and results (the restricting factor
 being the )
 
 \begin{code}
-isFFIArgumentTy :: DynFlags -> Bool -> Type -> Bool
+isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
 -- Checks for valid argument type for a 'foreign import'
-isFFIArgumentTy dflags is_safe ty 
-   = checkRepTyCon (legalOutgoingTyCon dflags is_safe) ty
+isFFIArgumentTy dflags safety ty 
+   = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
 
 isFFIExternalTy :: Type -> Bool
 -- Types that are allowed as arguments of a 'foreign export'
@@ -452,19 +462,19 @@ isFFIExportResultTy :: Type -> Bool
 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
 
 isFFIDynArgumentTy :: Type -> Bool
--- The argument type of a foreign import dynamic must be Ptr, Addr,
+-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
 -- or a newtype of either.
-isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == addrTyCon)
+isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
 
 isFFIDynResultTy :: Type -> Bool
--- The result type of a foreign export dynamic must be Ptr, Addr,
+-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
 -- or a newtype of either.
-isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == addrTyCon)
+isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
 
 isFFILabelTy :: Type -> Bool
--- The type of a foreign label must be Ptr, Addr,
+-- The type of a foreign label must be Ptr, FunPtr, Addr,
 -- or a newtype of either.
-isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == addrTyCon)
+isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
 
 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
        -- look through newtypes
@@ -513,12 +523,10 @@ legalFEResultTyCon tc
   | tc == unitTyCon = True
   | otherwise       = boxedMarshalableTyCon tc
 
-legalOutgoingTyCon :: DynFlags -> Bool -> TyCon -> Bool
+legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
 -- Checks validity of types going from Haskell -> external world
--- The boolean is true for a 'safe' call (when we don't want to
--- pass Haskell pointers to the world)
-legalOutgoingTyCon dflags be_safe tc
-  | be_safe && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
+legalOutgoingTyCon dflags safety tc
+  | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
   = False
   | otherwise
   = marshalableTyCon dflags tc
@@ -533,7 +541,7 @@ boxedMarshalableTyCon tc
                         , wordTyConKey, word8TyConKey, word16TyConKey
                         , word32TyConKey, word64TyConKey
                         , floatTyConKey, doubleTyConKey
-                        , addrTyConKey, ptrTyConKey
+                        , addrTyConKey, ptrTyConKey, funPtrTyConKey
                         , charTyConKey, foreignObjTyConKey
                         , foreignPtrTyConKey
                         , stablePtrTyConKey