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