ghc/lib/std/PrelStorable.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: PrelStorable.lhs,v 1.3 2001/02/28 00:01:03 qrczak 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 Bool where
  84    sizeOf _          = sizeOf (undefined::CInt)
  85    alignment _       = alignment (undefined::CInt)
  86    peekElemOff p i   = liftM (/= (0::CInt)) $ peekElemOff (castPtr p) i
  87    pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::CInt)
  88
  89 instance Storable (FunPtr a) where
  90    sizeOf          (FunPtr x) = sizeOf x
  91    alignment       (FunPtr x) = alignment x
  92    peekElemOff p i            = liftM FunPtr $ peekElemOff (castPtr p) i
  93    pokeElemOff p i (FunPtr x) = pokeElemOff (castPtr p) i x
  94
  95 #define STORABLE(T,size,align,read,write)       \
  96 instance Storable (T) where {                   \
  97     sizeOf    _ = size;                         \
  98     alignment _ = align;                        \
  99     peekElemOff = read;                         \
 100     pokeElemOff = write }
 101
 102 STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,
 103          readWideCharOffPtr,writeWideCharOffPtr)
 104
 105 STORABLE(Int,SIZEOF_LONG,ALIGNMENT_LONG,
 106          readIntOffPtr,writeIntOffPtr)
 107
 108 STORABLE(Word,SIZEOF_LONG,ALIGNMENT_LONG,
 109          readWordOffPtr,writeWordOffPtr)
 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 readWideCharOffPtr  :: Ptr Char          -> Int -> IO Char
 182 readIntOffPtr       :: Ptr Int           -> Int -> IO Int
 183 readWordOffPtr      :: Ptr Word          -> Int -> IO Word
 184 readPtrOffPtr       :: Ptr (Ptr a)       -> Int -> IO (Ptr a)
 185 readFloatOffPtr     :: Ptr Float         -> Int -> IO Float
 186 readDoubleOffPtr    :: Ptr Double        -> Int -> IO Double
 187 readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a)
 188 readInt8OffPtr      :: Ptr Int8          -> Int -> IO Int8
 189 readInt16OffPtr     :: Ptr Int16         -> Int -> IO Int16
 190 readInt32OffPtr     :: Ptr Int32         -> Int -> IO Int32
 191 readInt64OffPtr     :: Ptr Int64         -> Int -> IO Int64
 192 readWord8OffPtr     :: Ptr Word8         -> Int -> IO Word8
 193 readWord16OffPtr    :: Ptr Word16        -> Int -> IO Word16
 194 readWord32OffPtr    :: Ptr Word32        -> Int -> IO Word32
 195 readWord64OffPtr    :: Ptr Word64        -> Int -> IO Word64
 196
 197 readWideCharOffPtr (Ptr a) (I# i)
 198   = IO $ \s -> case readWideCharOffAddr# a i s  of (# s2, x #) -> (# s2, C# x #)
 199 readIntOffPtr (Ptr a) (I# i)
 200   = IO $ \s -> case readIntOffAddr# a i s       of (# s2, x #) -> (# s2, I# x #)
 201 readWordOffPtr (Ptr a) (I# i)
 202   = IO $ \s -> case readWordOffAddr# a i s      of (# s2, x #) -> (# s2, W# x #)
 203 readPtrOffPtr (Ptr a) (I# i)
 204   = IO $ \s -> case readAddrOffAddr# a i s      of (# s2, x #) -> (# s2, Ptr x #)
 205 readFloatOffPtr (Ptr a) (I# i)
 206   = IO $ \s -> case readFloatOffAddr# a i s     of (# s2, x #) -> (# s2, F# x #)
 207 readDoubleOffPtr (Ptr a) (I# i)
 208   = IO $ \s -> case readDoubleOffAddr# a i s    of (# s2, x #) -> (# s2, D# x #)
 209 readStablePtrOffPtr (Ptr a) (I# i)
 210   = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #)
 211 readInt8OffPtr (Ptr a) (I# i)
 212   = IO $ \s -> case readInt8OffAddr# a i s      of (# s2, x #) -> (# s2, I8# x #)
 213 readInt16OffPtr (Ptr a) (I# i)
 214   = IO $ \s -> case readInt16OffAddr# a i s     of (# s2, x #) -> (# s2, I16# x #)
 215 readInt32OffPtr (Ptr a) (I# i)
 216   = IO $ \s -> case readInt32OffAddr# a i s     of (# s2, x #) -> (# s2, I32# x #)
 217 readInt64OffPtr (Ptr a) (I# i)
 218   = IO $ \s -> case readInt64OffAddr# a i s     of (# s2, x #) -> (# s2, I64# x #)
 219 readWord8OffPtr (Ptr a) (I# i)
 220   = IO $ \s -> case readWord8OffAddr# a i s     of (# s2, x #) -> (# s2, W8# x #)
 221 readWord16OffPtr (Ptr a) (I# i)
 222   = IO $ \s -> case readWord16OffAddr# a i s    of (# s2, x #) -> (# s2, W16# x #)
 223 readWord32OffPtr (Ptr a) (I# i)
 224   = IO $ \s -> case readWord32OffAddr# a i s    of (# s2, x #) -> (# s2, W32# x #)
 225 readWord64OffPtr (Ptr a) (I# i)
 226   = IO $ \s -> case readWord64OffAddr# a i s    of (# s2, x #) -> (# s2, W64# x #)
 227
 228 writeWideCharOffPtr  :: Ptr Char          -> Int -> Char        -> IO ()
 229 writeIntOffPtr       :: Ptr Int           -> Int -> Int         -> IO ()
 230 writeWordOffPtr      :: Ptr Word          -> Int -> Word        -> IO ()
 231 writePtrOffPtr       :: Ptr (Ptr a)       -> Int -> Ptr a       -> IO ()
 232 writeFloatOffPtr     :: Ptr Float         -> Int -> Float       -> IO ()
 233 writeDoubleOffPtr    :: Ptr Double        -> Int -> Double      -> IO ()
 234 writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO ()
 235 writeInt8OffPtr      :: Ptr Int8          -> Int -> Int8        -> IO ()
 236 writeInt16OffPtr     :: Ptr Int16         -> Int -> Int16       -> IO ()
 237 writeInt32OffPtr     :: Ptr Int32         -> Int -> Int32       -> IO ()
 238 writeInt64OffPtr     :: Ptr Int64         -> Int -> Int64       -> IO ()
 239 writeWord8OffPtr     :: Ptr Word8         -> Int -> Word8       -> IO ()
 240 writeWord16OffPtr    :: Ptr Word16        -> Int -> Word16      -> IO ()
 241 writeWord32OffPtr    :: Ptr Word32        -> Int -> Word32      -> IO ()
 242 writeWord64OffPtr    :: Ptr Word64        -> Int -> Word64      -> IO ()
 243
 244 writeWideCharOffPtr (Ptr a) (I# i) (C# x)
 245   = IO $ \s -> case writeWideCharOffAddr# a i x s  of s2 -> (# s2, () #)
 246 writeIntOffPtr (Ptr a) (I# i) (I# x)
 247   = IO $ \s -> case writeIntOffAddr# a i x s       of s2 -> (# s2, () #)
 248 writeWordOffPtr (Ptr a) (I# i) (W# x)
 249   = IO $ \s -> case writeWordOffAddr# a i x s      of s2 -> (# s2, () #)
 250 writePtrOffPtr (Ptr a) (I# i) (Ptr x)
 251   = IO $ \s -> case writeAddrOffAddr# a i x s      of s2 -> (# s2, () #)
 252 writeFloatOffPtr (Ptr a) (I# i) (F# x)
 253   = IO $ \s -> case writeFloatOffAddr# a i x s     of s2 -> (# s2, () #)
 254 writeDoubleOffPtr (Ptr a) (I# i) (D# x)
 255   = IO $ \s -> case writeDoubleOffAddr# a i x s    of s2 -> (# s2, () #)
 256 writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x)
 257   = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #)
 258 writeInt8OffPtr (Ptr a) (I# i) (I8# x)
 259   = IO $ \s -> case writeInt8OffAddr# a i x s      of s2 -> (# s2, () #)
 260 writeInt16OffPtr (Ptr a) (I# i) (I16# x)
 261   = IO $ \s -> case writeInt16OffAddr# a i x s     of s2 -> (# s2, () #)
 262 writeInt32OffPtr (Ptr a) (I# i) (I32# x)
 263   = IO $ \s -> case writeInt32OffAddr# a i x s     of s2 -> (# s2, () #)
 264 writeInt64OffPtr (Ptr a) (I# i) (I64# x)
 265   = IO $ \s -> case writeInt64OffAddr# a i x s     of s2 -> (# s2, () #)
 266 writeWord8OffPtr (Ptr a) (I# i) (W8# x)
 267   = IO $ \s -> case writeWord8OffAddr# a i x s     of s2 -> (# s2, () #)
 268 writeWord16OffPtr (Ptr a) (I# i) (W16# x)
 269   = IO $ \s -> case writeWord16OffAddr# a i x s    of s2 -> (# s2, () #)
 270 writeWord32OffPtr (Ptr a) (I# i) (W32# x)
 271   = IO $ \s -> case writeWord32OffAddr# a i x s    of s2 -> (# s2, () #)
 272 writeWord64OffPtr (Ptr a) (I# i) (W64# x)
 273   = IO $ \s -> case writeWord64OffAddr# a i x s    of s2 -> (# s2, () #)
 274
 275 #endif /* __GLASGOW_HASKELL__ */
 276 \end{code}