1 % -----------------------------------------------------------------------------
2 % $Id: PrelStorable.lhs,v 1.2 2001/02/05 11:49:20 chak Exp $
4 % (c) The FFI task force, 2000
7 A class for primitive marshaling
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 ()
26 import Char ( chr, ord )
27 import Monad ( liftM )
29 #ifdef __GLASGOW_HASKELL__
30 import PrelStable ( StablePtr )
45 Minimal complete definition: sizeOf, alignment, and one definition
46 in each of the peek/poke families.
49 class Storable a where
51 -- sizeOf/alignment *never* use their first argument
55 -- replacement for read-/write???OffAddr
56 peekElemOff :: Ptr a -> Int -> IO a
57 pokeElemOff :: Ptr a -> Int -> a -> IO ()
59 -- the same with *byte* offsets
60 peekByteOff :: Ptr b -> Int -> IO a
61 pokeByteOff :: Ptr b -> Int -> a -> IO ()
63 -- ... and with no offsets at all
65 poke :: Ptr a -> a -> IO ()
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
73 peekByteOff ptr off = peek (ptr `plusPtr` off)
74 pokeByteOff ptr off = poke (ptr `plusPtr` off)
76 peek ptr = peekElemOff ptr 0
77 poke ptr = pokeElemOff ptr 0
80 System-dependent, but rather obvious instances
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))
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)
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
101 #define STORABLE(T,size,align,read,write) \
102 instance Storable (T) where { \
104 alignment _ = align; \
105 peekElemOff a i = read a i; \
106 pokeElemOff a i x = write a i x }
108 STORABLE(Int,SIZEOF_INT,ALIGNMENT_INT,
109 readIntOffPtr,writeIntOffPtr)
111 STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
112 readPtrOffPtr,writePtrOffPtr)
114 STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
115 readStablePtrOffPtr,writeStablePtrOffPtr)
117 STORABLE(Float,SIZEOF_FLOAT,ALIGNMENT_FLOAT,
118 readFloatOffPtr,writeFloatOffPtr)
120 STORABLE(Double,SIZEOF_DOUBLE,ALIGNMENT_DOUBLE,
121 readDoubleOffPtr,writeDoubleOffPtr)
123 STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8,
124 readWord8OffPtr,writeWord8OffPtr)
126 STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16,
127 readWord16OffPtr,writeWord16OffPtr)
129 STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32,
130 readWord32OffPtr,writeWord32OffPtr)
132 STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64,
133 readWord64OffPtr,writeWord64OffPtr)
135 STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8,
136 readInt8OffPtr,writeInt8OffPtr)
138 STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16,
139 readInt16OffPtr,writeInt16OffPtr)
141 STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32,
142 readInt32OffPtr,writeInt32OffPtr)
144 STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
145 readInt64OffPtr,writeInt64OffPtr)
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 }
171 NSTORABLE(CSigAtomic)
179 #ifdef __GLASGOW_HASKELL__
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
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 #) }
206 readInt8OffPtr (Ptr a) (I# i)
207 = IO $ \s -> case readInt8OffAddr# a i s of (# s, w #) -> (# s, I8# w #)
209 readInt16OffPtr (Ptr a) (I# i)
210 = IO $ \s -> case readInt16OffAddr# a i s of (# s, w #) -> (# s, I16# w #)
212 readInt32OffPtr (Ptr a) (I# i)
213 = IO $ \s -> case readInt32OffAddr# a i s of (# s, w #) -> (# s, I32# w #)
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 #)
219 readInt64OffPtr (Ptr a) (I# i)
220 = IO $ \s -> case readInt64OffAddr# a i s of (# s, w #) -> (# s, I64# w #)
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 ()
238 writeIntOffPtr (Ptr a#) (I# i#) (I# e#) = IO $ \ s# ->
239 case (writeIntOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
241 writePtrOffPtr (Ptr a#) (I# i#) (Ptr e#) = IO $ \ s# ->
242 case (writeAddrOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
244 writeFloatOffPtr (Ptr a#) (I# i#) (F# e#) = IO $ \ s# ->
245 case (writeFloatOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
247 writeDoubleOffPtr (Ptr a#) (I# i#) (D# e#) = IO $ \ s# ->
248 case (writeDoubleOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
250 writeStablePtrOffPtr (Ptr a#) (I# i#) (StablePtr e#) = IO $ \ s# ->
251 case (writeStablePtrOffAddr# a# i# e# s#) of s2# -> (# s2# , () #)
253 writeInt8OffPtr (Ptr a#) (I# i#) (I8# w#) = IO $ \ s# ->
254 case (writeInt8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
256 writeInt16OffPtr (Ptr a#) (I# i#) (I16# w#) = IO $ \ s# ->
257 case (writeInt16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
259 writeInt32OffPtr (Ptr a#) (I# i#) (I32# w#) = IO $ \ s# ->
260 case (writeInt32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
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#, () #)
266 writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# ->
267 case (writeInt64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
270 readWord8OffPtr (Ptr a) (I# i)
271 = IO $ \s -> case readWord8OffAddr# a i s of (# s, w #) -> (# s, W8# w #)
273 readWord16OffPtr (Ptr a) (I# i)
274 = IO $ \s -> case readWord16OffAddr# a i s of (# s, w #) -> (# s, W16# w #)
276 readWord32OffPtr (Ptr a) (I# i)
277 = IO $ \s -> case readWord32OffAddr# a i s of (# s, w #) -> (# s, W32# w #)
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 #)
283 readWord64OffPtr (Ptr a) (I# i)
284 = IO $ \s -> case readWord64OffAddr# a i s of (# s, w #) -> (# s, W64# w #)
287 writeWord8OffPtr (Ptr a#) (I# i#) (W8# w#) = IO $ \ s# ->
288 case (writeWord8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
290 writeWord16OffPtr (Ptr a#) (I# i#) (W16# w#) = IO $ \ s# ->
291 case (writeWord16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
293 writeWord32OffPtr (Ptr a#) (I# i#) (W32# w#) = IO $ \ s# ->
294 case (writeWord32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
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#, () #)
300 writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# ->
301 case (writeWord64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
304 #endif /* __GLASGOW_HASKELL__ */