ghc/lib/std/PrelForeign.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[Foreign]{Module @Foreign@}
   6
   7 \begin{code}
   8 {-# OPTIONS -fno-implicit-prelude #-}
   9
  10 module PrelForeign (
  11         module PrelForeign,
  12 #ifndef __PARALLEL_HASKELL__
  13         ForeignObj(..),
  14         makeForeignObj,
  15         writeForeignObj
  16 #endif
  17    ) where
  18
  19 import PrelIOBase
  20 import PrelST
  21 import PrelBase
  22 import PrelCCall
  23 import PrelAddr
  24 import PrelGHC
  25 \end{code}
  26
  27
  28 %*********************************************************
  29 %*                                                      *
  30 \subsection{Type @ForeignObj@ and its operations}
  31 %*                                                      *
  32 %*********************************************************
  33
  34 \begin{code}
  35 #ifndef __PARALLEL_HASKELL__
  36 --instance CCallable ForeignObj
  37 --instance CCallable ForeignObj#
  38
  39 makeForeignObj  :: Addr -> IO ForeignObj
  40 makeForeignObj (A# obj) = IO ( \ s# ->
  41     case makeForeignObj# obj s# of
  42       (# s1#, fo# #) -> (# s1#,  ForeignObj fo# #) )
  43
  44 eqForeignObj    :: ForeignObj  -> ForeignObj -> Bool
  45 --makeForeignObj  :: Addr        -> Addr       -> IO ForeignObj
  46 writeForeignObj :: ForeignObj  -> Addr       -> IO ()
  47
  48 writeForeignObj (ForeignObj fo#) (A# datum#) = IO ( \ s# ->
  49     case writeForeignObj# fo# datum# s# of { s1# -> (# s1#, () #) } )
  50
  51 eqForeignObj mp1 mp2
  52   = unsafePerformIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
  53
  54 instance Eq ForeignObj where
  55     p == q = eqForeignObj p q
  56     p /= q = not (eqForeignObj p q)
  57 #endif /* !__PARALLEL_HASKELL__ */
  58 \end{code}
  59
  60 %*********************************************************
  61 %*                                                      *
  62 \subsection{Type @StablePtr@ and its operations}
  63 %*                                                      *
  64 %*********************************************************
  65
  66 \begin{code}
  67 #ifndef __PARALLEL_HASKELL__
  68 data StablePtr a = StablePtr (StablePtr# a)
  69 instance CCallable   (StablePtr a)
  70 instance CCallable   (StablePtr# a)
  71 instance CReturnable (StablePtr a)
  72
  73 -- Nota Bene: it is important {\em not\/} to inline calls to
  74 -- @makeStablePtr#@ since the corresponding macro is very long and we'll
  75 -- get terrible code-bloat.
  76
  77 makeStablePtr  :: a -> IO (StablePtr a)
  78 deRefStablePtr :: StablePtr a -> IO a
  79 freeStablePtr  :: StablePtr a -> IO ()
  80
  81 {-# INLINE deRefStablePtr #-}
  82 {-# INLINE freeStablePtr #-}
  83
  84 makeStablePtr f = IO $ \ rw1# ->
  85     case makeStablePtr# f rw1# of
  86       (# rw2#, sp# #) -> (# rw2#, StablePtr sp# #)
  87
  88 deRefStablePtr (StablePtr sp#) = IO $ \ rw1# ->
  89     deRefStablePtr# sp# rw1#
  90
  91 freeStablePtr sp = _ccall_ freeStablePointer sp
  92
  93 eqStablePtr :: StablePtr a -> StablePtr b -> Bool
  94 eqStablePtr (StablePtr sp1#) (StablePtr sp2#) =
  95   case eqStablePtr# sp1# sp2# of
  96     0# -> False
  97     _  -> True
  98
  99 instance Eq (StablePtr a) where
 100     p == q = eqStablePtr p q
 101     p /= q = not (eqStablePtr p q)
 102
 103 #endif /* !__PARALLEL_HASKELL__ */
 104 \end{code}
 105
 106 %*********************************************************
 107 %*                                                      *
 108 \subsection{Unpacking Foreigns}
 109 %*                                                      *
 110 %*********************************************************
 111
 112 Primitives for converting Foreigns pointing to external
 113 sequence of bytes into a list of @Char@s (a renamed version
 114 of the code above).
 115
 116 \begin{code}
 117 #ifndef __PARALLEL_HASKELL__
 118 unpackCStringFO :: ForeignObj -> [Char]
 119 unpackCStringFO (ForeignObj fo#) = unpackCStringFO# fo#
 120
 121 unpackCStringFO# :: ForeignObj# -> [Char]
 122 unpackCStringFO# fo {- ptr. to NUL terminated string-}
 123   = unpack 0#
 124   where
 125     unpack nh
 126       | ch `eqChar#` '\0'# = []
 127       | otherwise          = C# ch : unpack (nh +# 1#)
 128       where
 129         ch = indexCharOffForeignObj# fo nh
 130
 131 unpackNBytesFO :: ForeignObj -> Int -> [Char]
 132 unpackNBytesFO (ForeignObj fo) (I# l) = unpackNBytesFO# fo l
 133
 134 unpackNBytesFO#    :: ForeignObj# -> Int#   -> [Char]
 135   -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
 136 unpackNBytesFO# fo len
 137   = unpack 0#
 138     where
 139      unpack i
 140       | i >=# len  = []
 141       | otherwise  = C# ch : unpack (i +# 1#)
 142       where
 143         ch = indexCharOffForeignObj# fo i
 144 #endif
 145 \end{code}