ghc/lib/std/PrelStorable.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: PrelStorable.lhs,v 1.2 2001/02/05 11:49:20 chak Exp $
   3 %
   4 % (c) The FFI task force, 2000
   5 %
   6
   7 A class for primitive marshaling
   8
   9 \begin{code}
  10 #include "MachDeps.h"
  11
  12 module PrelStorable
  13         ( Storable(
  14              sizeOf,         -- :: a -> Int
  15              alignment,      -- :: a -> Int
  16              peekElemOff,    -- :: Ptr a -> Int      -> IO a
  17              pokeElemOff,    -- :: Ptr a -> Int -> a -> IO ()
  18              peekByteOff,    -- :: Ptr b -> Int      -> IO a
  19              pokeByteOff,    -- :: Ptr b -> Int -> a -> IO ()
  20              peek,           -- :: Ptr a             -> IO a
  21              poke)           -- :: Ptr a        -> a -> IO ()
  22         ) where
  23 \end{code}
  24
  25 \begin{code}
  26 import Char             ( chr, ord )
  27 import Monad            ( liftM )
  28
  29 #ifdef __GLASGOW_HASKELL__
  30 import PrelStable       ( StablePtr )
  31 import PrelInt
  32 import PrelWord
  33 import PrelCTypes
  34 import PrelCTypesISO
  35 import PrelStable
  36 import PrelPtr
  37 import PrelFloat
  38 import PrelIOBase
  39 import PrelBase
  40 #endif
  41 \end{code}
  42
  43 Primitive marshaling
  44
  45 Minimal complete definition: sizeOf, alignment, and one definition
  46 in each of the peek/poke families.
  47
  48 \begin{code}
  49 class Storable a where
  50
  51    -- sizeOf/alignment *never* use their first argument
  52    sizeOf      :: a -> Int
  53    alignment   :: a -> Int
  54
  55    -- replacement for read-/write???OffAddr
  56    peekElemOff :: Ptr a -> Int      -> IO a
  57    pokeElemOff :: Ptr a -> Int -> a -> IO ()
  58
  59    -- the same with *byte* offsets
  60    peekByteOff :: Ptr b -> Int      -> IO a
  61    pokeByteOff :: Ptr b -> Int -> a -> IO ()
  62
  63    -- ... and with no offsets at all
  64    peek        :: Ptr a      -> IO a
  65    poke        :: Ptr a -> a -> IO ()
  66
  67    -- circular default instances
  68    peekElemOff = peekElemOff_ undefined
  69       where peekElemOff_ :: a -> Ptr a -> Int -> IO a
  70             peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)
  71    pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val
  72
  73    peekByteOff ptr off = peek (ptr `plusPtr` off)
  74    pokeByteOff ptr off = poke (ptr `plusPtr` off)
  75
  76    peek ptr = peekElemOff ptr 0
  77    poke ptr = pokeElemOff ptr 0
  78 \end{code}
  79
  80 System-dependent, but rather obvious instances
  81
  82 \begin{code}
  83 instance Storable Char where
  84    sizeOf _          = sizeOf (undefined::Word32)
  85    alignment _       = alignment (undefined::Word32)
  86    peekElemOff p i   = liftM (chr . fromIntegral) $ peekElemOff (castPtr p::Ptr Word32) i
  87    pokeElemOff p i x = pokeElemOff (castPtr p::Ptr Word32) i (fromIntegral (ord x))
  88
  89 instance Storable Bool where
  90    sizeOf _          = sizeOf (undefined::CInt)
  91    alignment _       = alignment (undefined::CInt)
  92    peekElemOff p i   = liftM (/= (0::CInt)) $ peekElemOff (castPtr p) i
  93    pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::CInt)
  94
  95 instance Storable (FunPtr a) where
  96    sizeOf          (FunPtr x) = sizeOf x
  97    alignment       (FunPtr x) = alignment x
  98    peekElemOff p i            = liftM FunPtr $ peekElemOff (castPtr p) i
  99    pokeElemOff p i (FunPtr x) = pokeElemOff (castPtr p) i x
 100
 101 #define STORABLE(T,size,align,read,write)               \
 102 instance Storable (T) where {                           \
 103     sizeOf    _       = size;                           \
 104     alignment _       = align;                          \
 105     peekElemOff a i   = read a i;                       \
 106     pokeElemOff a i x = write a i x }
 107
 108 STORABLE(Int,SIZEOF_INT,ALIGNMENT_INT,
 109          readIntOffPtr,writeIntOffPtr)
 110
 111 STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
 112          readPtrOffPtr,writePtrOffPtr)
 113
 114 STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
 115          readStablePtrOffPtr,writeStablePtrOffPtr)
 116
 117 STORABLE(Float,SIZEOF_FLOAT,ALIGNMENT_FLOAT,
 118          readFloatOffPtr,writeFloatOffPtr)
 119
 120 STORABLE(Double,SIZEOF_DOUBLE,ALIGNMENT_DOUBLE,
 121          readDoubleOffPtr,writeDoubleOffPtr)
 122
 123 STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,
 124          readWord8OffPtr,writeWord8OffPtr)
 125
 126 STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,
 127          readWord16OffPtr,writeWord16OffPtr)
 128
 129 STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,
 130          readWord32OffPtr,writeWord32OffPtr)
 131
 132 STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,
 133          readWord64OffPtr,writeWord64OffPtr)
 134
 135 STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,
 136          readInt8OffPtr,writeInt8OffPtr)
 137
 138 STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,
 139          readInt16OffPtr,writeInt16OffPtr)
 140
 141 STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,
 142          readInt32OffPtr,writeInt32OffPtr)
 143
 144 STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
 145          readInt64OffPtr,writeInt64OffPtr)
 146
 147 #define NSTORABLE(T) \
 148 instance Storable T where { \
 149    sizeOf    (T x)       = sizeOf x ; \
 150    alignment (T x)       = alignment x ; \
 151    peekElemOff a i       = liftM T (peekElemOff (castPtr a) i) ; \
 152    pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x }
 153
 154 NSTORABLE(CChar)
 155 NSTORABLE(CSChar)
 156 NSTORABLE(CUChar)
 157 NSTORABLE(CShort)
 158 NSTORABLE(CUShort)
 159 NSTORABLE(CInt)
 160 NSTORABLE(CUInt)
 161 NSTORABLE(CLong)
 162 NSTORABLE(CULong)
 163 NSTORABLE(CLLong)
 164 NSTORABLE(CULLong)
 165 NSTORABLE(CFloat)
 166 NSTORABLE(CDouble)
 167 NSTORABLE(CLDouble)
 168 NSTORABLE(CPtrdiff)
 169 NSTORABLE(CSize)
 170 NSTORABLE(CWchar)
 171 NSTORABLE(CSigAtomic)
 172 NSTORABLE(CClock)
 173 NSTORABLE(CTime)
 174 \end{code}
 175
 176 Helper functions
 177
 178 \begin{code}
 179 #ifdef __GLASGOW_HASKELL__
 180
 181 readIntOffPtr         :: Ptr Int           -> Int -> IO Int
 182 readPtrOffPtr         :: Ptr (Ptr a)       -> Int -> IO (Ptr a)
 183 readFloatOffPtr       :: Ptr Float         -> Int -> IO Float
 184 readDoubleOffPtr      :: Ptr Double        -> Int -> IO Double
 185 readStablePtrOffPtr   :: Ptr (StablePtr a) -> Int -> IO (StablePtr a)
 186 readInt8OffPtr        :: Ptr Int8          -> Int -> IO Int8
 187 readInt16OffPtr       :: Ptr Int16         -> Int -> IO Int16
 188 readInt32OffPtr       :: Ptr Int32         -> Int -> IO Int32
 189 readInt64OffPtr       :: Ptr Int64         -> Int -> IO Int64
 190 readWord8OffPtr       :: Ptr Word8         -> Int -> IO Word8
 191 readWord16OffPtr      :: Ptr Word16        -> Int -> IO Word16
 192 readWord32OffPtr      :: Ptr Word32        -> Int -> IO Word32
 193 readWord64OffPtr      :: Ptr Word64        -> Int -> IO Word64
 194
 195 readIntOffPtr (Ptr a) (I# i)
 196   = IO $ \s -> case readIntOffAddr# a i s        of { (# s,x #) -> (# s, I# x #) }
 197 readPtrOffPtr (Ptr a) (I# i)
 198   = IO $ \s -> case readAddrOffAddr# a i s       of { (# s,x #) -> (# s, Ptr x #) }
 199 readFloatOffPtr (Ptr a) (I# i)
 200   = IO $ \s -> case readFloatOffAddr# a i s      of { (# s,x #) -> (# s, F# x #) }
 201 readDoubleOffPtr (Ptr a) (I# i)
 202   = IO $ \s -> case readDoubleOffAddr# a i s     of { (# s,x #) -> (# s, D# x #) }
 203 readStablePtrOffPtr (Ptr a) (I# i)
 204   = IO $ \s -> case readStablePtrOffAddr# a i s  of { (# s,x #) -> (# s, StablePtr x #) }
 205
 206 readInt8OffPtr (Ptr a) (I# i)
 207   = IO $ \s -> case readInt8OffAddr# a i s of (# s, w #) -> (# s, I8# w #)
 208
 209 readInt16OffPtr (Ptr a) (I# i)
 210   = IO $ \s -> case readInt16OffAddr# a i s of (# s, w #) -> (# s, I16# w #)
 211
 212 readInt32OffPtr (Ptr a) (I# i)
 213   = IO $ \s -> case readInt32OffAddr# a i s of (# s, w #) -> (# s, I32# w #)
 214
 215 #if WORD_SIZE_IN_BYTES == 8
 216 readInt64OffPtr (Ptr a) (I# i)
 217   = IO $ \s -> case readIntOffAddr# a i s of (# s, w #) -> (# s, I64# w #)
 218 #else
 219 readInt64OffPtr (Ptr a) (I# i)
 220   = IO $ \s -> case readInt64OffAddr# a i s of (# s, w #) -> (# s, I64# w #)
 221 #endif
 222
 223
 224 writeIntOffPtr        :: Ptr Int            -> Int -> Int          -> IO ()
 225 writePtrOffPtr        :: Ptr (Ptr a)        -> Int -> Ptr a        -> IO ()
 226 writeFloatOffPtr      :: Ptr Float          -> Int -> Float        -> IO ()
 227 writeDoubleOffPtr     :: Ptr Double         -> Int -> Double       -> IO ()
 228 writeStablePtrOffPtr  :: Ptr (StablePtr a)  -> Int -> StablePtr a  -> IO ()
 229 writeInt8OffPtr       :: Ptr Int8           -> Int -> Int8         -> IO ()
 230 writeInt16OffPtr      :: Ptr Int16          -> Int -> Int16        -> IO ()
 231 writeInt32OffPtr      :: Ptr Int32          -> Int -> Int32        -> IO ()
 232 writeInt64OffPtr      :: Ptr Int64          -> Int -> Int64        -> IO ()
 233 writeWord8OffPtr      :: Ptr Word8          -> Int -> Word8        -> IO ()
 234 writeWord16OffPtr     :: Ptr Word16         -> Int -> Word16       -> IO ()
 235 writeWord32OffPtr     :: Ptr Word32         -> Int -> Word32       -> IO ()
 236 writeWord64OffPtr     :: Ptr Word64         -> Int -> Word64       -> IO ()
 237
 238 writeIntOffPtr (Ptr a#) (I# i#) (I# e#) = IO $ \ s# ->
 239       case (writeIntOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 240
 241 writePtrOffPtr (Ptr a#) (I# i#) (Ptr e#) = IO $ \ s# ->
 242       case (writeAddrOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 243
 244 writeFloatOffPtr (Ptr a#) (I# i#) (F# e#) = IO $ \ s# ->
 245       case (writeFloatOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 246
 247 writeDoubleOffPtr (Ptr a#) (I# i#) (D# e#) = IO $ \ s# ->
 248       case (writeDoubleOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 249
 250 writeStablePtrOffPtr (Ptr a#) (I# i#) (StablePtr e#) = IO $ \ s# ->
 251       case (writeStablePtrOffAddr#  a# i# e# s#) of s2# -> (# s2# , () #)
 252
 253 writeInt8OffPtr (Ptr a#) (I# i#) (I8# w#) = IO $ \ s# ->
 254       case (writeInt8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 255
 256 writeInt16OffPtr (Ptr a#) (I# i#) (I16# w#) = IO $ \ s# ->
 257       case (writeInt16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 258
 259 writeInt32OffPtr (Ptr a#) (I# i#) (I32# w#) = IO $ \ s# ->
 260       case (writeInt32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 261
 262 #if WORD_SIZE_IN_BYTES == 8
 263 writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# ->
 264       case (writeIntOffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 265 #else
 266 writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# ->
 267       case (writeInt64OffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 268 #endif
 269
 270 readWord8OffPtr (Ptr a) (I# i)
 271   = IO $ \s -> case readWord8OffAddr# a i s of (# s, w #) -> (# s, W8# w #)
 272
 273 readWord16OffPtr (Ptr a) (I# i)
 274   = IO $ \s -> case readWord16OffAddr# a i s of (# s, w #) -> (# s, W16# w #)
 275
 276 readWord32OffPtr (Ptr a) (I# i)
 277   = IO $ \s -> case readWord32OffAddr# a i s of (# s, w #) -> (# s, W32# w #)
 278
 279 #if WORD_SIZE_IN_BYTES == 8
 280 readWord64OffPtr (Ptr a) (I# i)
 281   = IO $ \s -> case readWordOffAddr# a i s of (# s, w #) -> (# s, W64# w #)
 282 #else
 283 readWord64OffPtr (Ptr a) (I# i)
 284   = IO $ \s -> case readWord64OffAddr# a i s of (# s, w #) -> (# s, W64# w #)
 285 #endif
 286
 287 writeWord8OffPtr (Ptr a#) (I# i#) (W8# w#) = IO $ \ s# ->
 288       case (writeWord8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 289
 290 writeWord16OffPtr (Ptr a#) (I# i#) (W16# w#) = IO $ \ s# ->
 291       case (writeWord16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 292
 293 writeWord32OffPtr (Ptr a#) (I# i#) (W32# w#) = IO $ \ s# ->
 294       case (writeWord32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 295
 296 #if WORD_SIZE_IN_BYTES == 8
 297 writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# ->
 298       case (writeWordOffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 299 #else
 300 writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# ->
 301       case (writeWord64OffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 302 #endif
 303
 304 #endif /* __GLASGOW_HASKELL__ */
 305 \end{code}