ghc/lib/std/PrelStorable.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: PrelStorable.lhs,v 1.1 2001/01/11 17:25:57 simonmar 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(CPtrdiff)
 166 NSTORABLE(CSize)
 167 NSTORABLE(CWchar)
 168 NSTORABLE(CSigAtomic)
 169 NSTORABLE(CClock)
 170 NSTORABLE(CTime)
 171 \end{code}
 172
 173 Helper functions
 174
 175 \begin{code}
 176 #ifdef __GLASGOW_HASKELL__
 177
 178 readIntOffPtr         :: Ptr Int           -> Int -> IO Int
 179 readPtrOffPtr         :: Ptr (Ptr a)       -> Int -> IO (Ptr a)
 180 readFloatOffPtr       :: Ptr Float         -> Int -> IO Float
 181 readDoubleOffPtr      :: Ptr Double        -> Int -> IO Double
 182 readStablePtrOffPtr   :: Ptr (StablePtr a) -> Int -> IO (StablePtr a)
 183 readInt8OffPtr        :: Ptr Int8          -> Int -> IO Int8
 184 readInt16OffPtr       :: Ptr Int16         -> Int -> IO Int16
 185 readInt32OffPtr       :: Ptr Int32         -> Int -> IO Int32
 186 readInt64OffPtr       :: Ptr Int64         -> Int -> IO Int64
 187 readWord8OffPtr       :: Ptr Word8         -> Int -> IO Word8
 188 readWord16OffPtr      :: Ptr Word16        -> Int -> IO Word16
 189 readWord32OffPtr      :: Ptr Word32        -> Int -> IO Word32
 190 readWord64OffPtr      :: Ptr Word64        -> Int -> IO Word64
 191
 192 readIntOffPtr (Ptr a) (I# i)
 193   = IO $ \s -> case readIntOffAddr# a i s        of { (# s,x #) -> (# s, I# x #) }
 194 readPtrOffPtr (Ptr a) (I# i)
 195   = IO $ \s -> case readAddrOffAddr# a i s       of { (# s,x #) -> (# s, Ptr x #) }
 196 readFloatOffPtr (Ptr a) (I# i)
 197   = IO $ \s -> case readFloatOffAddr# a i s      of { (# s,x #) -> (# s, F# x #) }
 198 readDoubleOffPtr (Ptr a) (I# i)
 199   = IO $ \s -> case readDoubleOffAddr# a i s     of { (# s,x #) -> (# s, D# x #) }
 200 readStablePtrOffPtr (Ptr a) (I# i)
 201   = IO $ \s -> case readStablePtrOffAddr# a i s  of { (# s,x #) -> (# s, StablePtr x #) }
 202
 203 readInt8OffPtr (Ptr a) (I# i)
 204   = IO $ \s -> case readInt8OffAddr# a i s of (# s, w #) -> (# s, I8# w #)
 205
 206 readInt16OffPtr (Ptr a) (I# i)
 207   = IO $ \s -> case readInt16OffAddr# a i s of (# s, w #) -> (# s, I16# w #)
 208
 209 readInt32OffPtr (Ptr a) (I# i)
 210   = IO $ \s -> case readInt32OffAddr# a i s of (# s, w #) -> (# s, I32# w #)
 211
 212 #if WORD_SIZE_IN_BYTES == 8
 213 readInt64OffPtr (Ptr a) (I# i)
 214   = IO $ \s -> case readIntOffAddr# a i s of (# s, w #) -> (# s, I64# w #)
 215 #else
 216 readInt64OffPtr (Ptr a) (I# i)
 217   = IO $ \s -> case readInt64OffAddr# a i s of (# s, w #) -> (# s, I64# w #)
 218 #endif
 219
 220
 221 writeIntOffPtr        :: Ptr Int            -> Int -> Int          -> IO ()
 222 writePtrOffPtr        :: Ptr (Ptr a)        -> Int -> Ptr a        -> IO ()
 223 writeFloatOffPtr      :: Ptr Float          -> Int -> Float        -> IO ()
 224 writeDoubleOffPtr     :: Ptr Double         -> Int -> Double       -> IO ()
 225 writeStablePtrOffPtr  :: Ptr (StablePtr a)  -> Int -> StablePtr a  -> IO ()
 226 writeInt8OffPtr       :: Ptr Int8           -> Int -> Int8         -> IO ()
 227 writeInt16OffPtr      :: Ptr Int16          -> Int -> Int16        -> IO ()
 228 writeInt32OffPtr      :: Ptr Int32          -> Int -> Int32        -> IO ()
 229 writeInt64OffPtr      :: Ptr Int64          -> Int -> Int64        -> IO ()
 230 writeWord8OffPtr      :: Ptr Word8          -> Int -> Word8        -> IO ()
 231 writeWord16OffPtr     :: Ptr Word16         -> Int -> Word16       -> IO ()
 232 writeWord32OffPtr     :: Ptr Word32         -> Int -> Word32       -> IO ()
 233 writeWord64OffPtr     :: Ptr Word64         -> Int -> Word64       -> IO ()
 234
 235 writeIntOffPtr (Ptr a#) (I# i#) (I# e#) = IO $ \ s# ->
 236       case (writeIntOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 237
 238 writePtrOffPtr (Ptr a#) (I# i#) (Ptr e#) = IO $ \ s# ->
 239       case (writeAddrOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 240
 241 writeFloatOffPtr (Ptr a#) (I# i#) (F# e#) = IO $ \ s# ->
 242       case (writeFloatOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 243
 244 writeDoubleOffPtr (Ptr a#) (I# i#) (D# e#) = IO $ \ s# ->
 245       case (writeDoubleOffAddr#  a# i# e# s#) of s2# -> (# s2#, () #)
 246
 247 writeStablePtrOffPtr (Ptr a#) (I# i#) (StablePtr e#) = IO $ \ s# ->
 248       case (writeStablePtrOffAddr#  a# i# e# s#) of s2# -> (# s2# , () #)
 249
 250 writeInt8OffPtr (Ptr a#) (I# i#) (I8# w#) = IO $ \ s# ->
 251       case (writeInt8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 252
 253 writeInt16OffPtr (Ptr a#) (I# i#) (I16# w#) = IO $ \ s# ->
 254       case (writeInt16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 255
 256 writeInt32OffPtr (Ptr a#) (I# i#) (I32# w#) = IO $ \ s# ->
 257       case (writeInt32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 258
 259 #if WORD_SIZE_IN_BYTES == 8
 260 writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# ->
 261       case (writeIntOffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 262 #else
 263 writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# ->
 264       case (writeInt64OffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 265 #endif
 266
 267 readWord8OffPtr (Ptr a) (I# i)
 268   = IO $ \s -> case readWord8OffAddr# a i s of (# s, w #) -> (# s, W8# w #)
 269
 270 readWord16OffPtr (Ptr a) (I# i)
 271   = IO $ \s -> case readWord16OffAddr# a i s of (# s, w #) -> (# s, W16# w #)
 272
 273 readWord32OffPtr (Ptr a) (I# i)
 274   = IO $ \s -> case readWord32OffAddr# a i s of (# s, w #) -> (# s, W32# w #)
 275
 276 #if WORD_SIZE_IN_BYTES == 8
 277 readWord64OffPtr (Ptr a) (I# i)
 278   = IO $ \s -> case readWordOffAddr# a i s of (# s, w #) -> (# s, W64# w #)
 279 #else
 280 readWord64OffPtr (Ptr a) (I# i)
 281   = IO $ \s -> case readWord64OffAddr# a i s of (# s, w #) -> (# s, W64# w #)
 282 #endif
 283
 284 writeWord8OffPtr (Ptr a#) (I# i#) (W8# w#) = IO $ \ s# ->
 285       case (writeWord8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 286
 287 writeWord16OffPtr (Ptr a#) (I# i#) (W16# w#) = IO $ \ s# ->
 288       case (writeWord16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 289
 290 writeWord32OffPtr (Ptr a#) (I# i#) (W32# w#) = IO $ \ s# ->
 291       case (writeWord32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
 292
 293 #if WORD_SIZE_IN_BYTES == 8
 294 writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# ->
 295       case (writeWordOffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 296 #else
 297 writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# ->
 298       case (writeWord64OffAddr#  a# i# w# s#) of s2# -> (# s2#, () #)
 299 #endif
 300
 301 #endif /* __GLASGOW_HASKELL__ */
 302 \end{code}