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 #endif
  15         Word(..),
  16
  17 #ifndef __PARALLEL_HASKELL__
  18         unpackCStringFO,   -- :: ForeignObj    -> [Char]
  19         unpackNBytesFO,    -- :: ForeignObj    -> Int  -> [Char]
  20         unpackCStringFO#,  -- :: ForeignObj#   -> [Char]
  21         unpackNBytesFO#    -- :: ForeignObj#   -> Int# -> [Char]
  22 #endif
  23    ) where
  24
  25 import PrelIOBase
  26 import PrelST
  27 import PrelBase
  28 import PrelCCall
  29 import PrelAddr
  30 import PrelGHC
  31 \end{code}
  32
  33
  34 %*********************************************************
  35 %*                                                      *
  36 \subsection{Type @ForeignObj@ and its operations}
  37 %*                                                      *
  38 %*********************************************************
  39
  40 \begin{code}
  41 #ifndef __PARALLEL_HASKELL__
  42 instance CCallable ForeignObj
  43 instance CCallable ForeignObj#
  44
  45 eqForeignObj    :: ForeignObj  -> ForeignObj -> Bool
  46 makeForeignObj  :: Addr        -> Addr       -> IO ForeignObj
  47 writeForeignObj :: ForeignObj  -> Addr       -> IO ()
  48
  49 {- derived op - attaching a free() finaliser to a malloc() allocated reference. -}
  50 makeMallocPtr   :: Addr        -> IO ForeignObj
  51
  52 makeForeignObj (A# obj) (A# finaliser) = IO ( \ s# ->
  53     case makeForeignObj# obj finaliser s# of
  54       StateAndForeignObj# s1# fo# -> IOok s1# (ForeignObj fo#))
  55
  56 writeForeignObj (ForeignObj fo#) (A# datum#) = IO ( \ s# ->
  57     case writeForeignObj# fo# datum# s# of { s1# -> IOok s1# () } )
  58
  59 makeMallocPtr a = makeForeignObj a (``&free''::Addr)
  60
  61 eqForeignObj mp1 mp2
  62   = unsafePerformIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
  63
  64 instance Eq ForeignObj where
  65     p == q = eqForeignObj p q
  66     p /= q = not (eqForeignObj p q)
  67 #endif /* !__PARALLEL_HASKELL__ */
  68 \end{code}
  69
  70 %*********************************************************
  71 %*                                                      *
  72 \subsection{Type @StablePtr@ and its operations}
  73 %*                                                      *
  74 %*********************************************************
  75
  76 \begin{code}
  77 #ifndef __PARALLEL_HASKELL__
  78 data StablePtr a = StablePtr (StablePtr# a)
  79 instance CCallable   (StablePtr a)
  80 instance CCallable   (StablePtr# a)
  81 instance CReturnable (StablePtr a)
  82
  83 -- Nota Bene: it is important {\em not\/} to inline calls to
  84 -- @makeStablePtr#@ since the corresponding macro is very long and we'll
  85 -- get terrible code-bloat.
  86
  87 makeStablePtr  :: a -> IO (StablePtr a)
  88 deRefStablePtr :: StablePtr a -> IO a
  89 freeStablePtr  :: StablePtr a -> IO ()
  90
  91 {-# INLINE deRefStablePtr #-}
  92 {-# INLINE freeStablePtr #-}
  93
  94 makeStablePtr f = IO $ \ rw1# ->
  95     case makeStablePtr# f rw1# of
  96       StateAndStablePtr# rw2# sp# -> IOok rw2# (StablePtr sp#)
  97
  98 deRefStablePtr (StablePtr sp#) = IO $ \ rw1# ->
  99     case deRefStablePtr# sp# rw1# of
 100       StateAndPtr# rw2# a -> IOok rw2# a
 101
 102 freeStablePtr sp = _ccall_ freeStablePointer sp
 103
 104 #endif /* !__PARALLEL_HASKELL__ */
 105 \end{code}
 106
 107 %*********************************************************
 108 %*                                                      *
 109 \subsection{Ghastly return types}
 110 %*                                                      *
 111 %*********************************************************
 112
 113 \begin{code}
 114 #ifndef __PARALLEL_HASKELL__
 115 data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
 116 #endif
 117 data StateAndForeignObj# s  = StateAndForeignObj# (State# s) ForeignObj#
 118 \end{code}
 119
 120 %*********************************************************
 121 %*                                                      *
 122 \subsection{Unpacking Foreigns}
 123 %*                                                      *
 124 %*********************************************************
 125
 126 Primitives for converting Foreigns pointing to external
 127 sequence of bytes into a list of @Char@s (a renamed version
 128 of the code above).
 129
 130 \begin{code}
 131 #ifndef __PARALLEL_HASKELL__
 132 unpackCStringFO :: ForeignObj -> [Char]
 133 unpackCStringFO (ForeignObj fo#) = unpackCStringFO# fo#
 134
 135 unpackCStringFO# :: ForeignObj# -> [Char]
 136 unpackCStringFO# fo {- ptr. to NUL terminated string-}
 137   = unpack 0#
 138   where
 139     unpack nh
 140       | ch `eqChar#` '\0'# = []
 141       | otherwise          = C# ch : unpack (nh +# 1#)
 142       where
 143         ch = indexCharOffForeignObj# fo nh
 144
 145 unpackNBytesFO :: ForeignObj -> Int -> [Char]
 146 unpackNBytesFO (ForeignObj fo) (I# l) = unpackNBytesFO# fo l
 147
 148 unpackNBytesFO#    :: ForeignObj# -> Int#   -> [Char]
 149   -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
 150 unpackNBytesFO# fo len
 151   = unpack 0#
 152     where
 153      unpack i
 154       | i >=# len  = []
 155       | otherwise  = C# ch : unpack (i +# 1#)
 156       where
 157         ch = indexCharOffForeignObj# fo i
 158 #endif
 159 \end{code}
 160
 161