2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
4 \section{Basic ops on packed representations}
6 Some basic operations for working on packed representations of series
7 of bytes (character strings). Used by the interface lexer input
13 strLength, -- :: _Addr -> Int
14 copyPrefixStr, -- :: _Addr -> Int -> ByteArray Int
15 copySubStr, -- :: _Addr -> Int -> Int -> ByteArray Int
16 copySubStrFO, -- :: ForeignObj -> Int -> Int -> ByteArray Int
17 copySubStrBA, -- :: ByteArray Int -> Int -> Int -> ByteArray Int
19 eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
20 eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
21 eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
22 eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
23 eqStrPrefixFO, -- :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
25 addrOffset# -- :: Addr# -> Int# -> Addr#
28 -- This #define suppresses the "import FastString" that
29 -- HsVersions otherwise produces
30 #define COMPILING_FAST_STRING
31 #include "HsVersions.h"
34 import PrelAddr ( Addr(..) )
37 -- ForeignObj is now exported abstractly.
38 #if __GLASGOW_HASKELL__ >= 303
39 import PrelForeign ( ForeignObj(..) )
42 #if __GLASGOW_HASKELL__ < 301
43 import ArrBase ( StateAndMutableByteArray#(..),
44 StateAndByteArray#(..) )
46 #elif __GLASGOW_HASKELL__ < 400
47 import PrelArr ( StateAndMutableByteArray#(..),
48 StateAndByteArray#(..) )
56 Return the length of a @\\NUL@ terminated character string:
59 strLength :: Addr -> Int
62 _ccall_ strlen a >>= \ len@(I# _) ->
65 {-# NOINLINE strLength #-}
68 Copying a char string prefix into a byte array,
69 {\em assuming} the prefix does not contain any
73 copyPrefixStr :: Addr -> Int -> ByteArray Int
74 copyPrefixStr (A# a) len@(I# length#) =
76 {- allocate an array that will hold the string
77 (not forgetting the NUL at the end)
79 (new_ps_array (length# +# 1#)) >>= \ ch_array ->
80 {- Revert back to Haskell-only solution for the moment.
81 _ccall_ memcpy ch_array (A# a) len >>= \ () ->
82 write_ps_array ch_array length# (chr# 0#) >>
84 -- fill in packed string from "addr"
85 fill_in ch_array 0# >>
87 freeze_ps_array ch_array length# >>= \ barr ->
90 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
94 = write_ps_array arr_in# idx (chr# 0#) >>
97 = case (indexCharOffAddr# a idx) of { ch ->
98 write_ps_array arr_in# idx ch >>
99 fill_in arr_in# (idx +# 1#) }
103 Copying out a substring, assume a 0-indexed string:
104 (and positive lengths, thank you).
107 copySubStr :: Addr -> Int -> Int -> ByteArray Int
108 copySubStr a start length =
110 _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
112 return (copyPrefixStr a_start length))
115 pCopying a sub-string out of a ForeignObj
118 copySubStrFO :: ForeignObj -> Int -> Int -> ByteArray Int
119 copySubStrFO (ForeignObj fo) (I# start#) len@(I# length#) =
121 {- allocate an array that will hold the string
122 (not forgetting the NUL at the end)
124 new_ps_array (length# +# 1#) >>= \ ch_array ->
125 -- fill in packed string from "addr"
126 fill_in ch_array 0# >>
128 freeze_ps_array ch_array length#)
130 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
134 = write_ps_array arr_in# idx (chr# 0#) >>
137 = case (indexCharOffForeignObj# fo (idx +# start#)) of { ch ->
138 write_ps_array arr_in# idx ch >>
139 fill_in arr_in# (idx +# 1#) }
141 -- step on (char *) pointer by x units.
142 addrOffset# :: Addr# -> Int# -> Addr#
144 case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
147 copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
148 #if __GLASGOW_HASKELL__ >= 405
149 copySubStrBA (ByteArray _ _ barr#) (I# start#) len@(I# length#) =
151 copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) =
154 {- allocate an array that will hold the string
155 (not forgetting the NUL at the end)
157 new_ps_array (length# +# 1#) >>= \ ch_array ->
158 -- fill in packed string from "addr"
159 fill_in ch_array 0# >>
161 freeze_ps_array ch_array length#)
163 fill_in :: MutableByteArray s Int -> Int# -> ST s ()
167 = write_ps_array arr_in# idx (chr# 0#) >>
170 = case (indexCharArray# barr# (start# +# idx)) of { ch ->
171 write_ps_array arr_in# idx ch >>
172 fill_in arr_in# (idx +# 1#) }
175 (Very :-) ``Specialised'' versions of some CharArray things...
176 [Copied from PackBase; no real reason -- UGH]
179 new_ps_array :: Int# -> ST s (MutableByteArray s Int)
180 write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
181 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
183 new_ps_array size = ST $ \ s ->
184 #if __GLASGOW_HASKELL__ < 400
185 case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
186 STret s2# (MutableByteArray bot barr#) }
187 #elif __GLASGOW_HASKELL__ < 405
188 case (newCharArray# size s) of { (# s2#, barr# #) ->
189 (# s2#, MutableByteArray bot barr# #) }
190 #elif __GLASGOW_HASKELL__ < 411
191 case (newCharArray# size s) of { (# s2#, barr# #) ->
192 (# s2#, MutableByteArray bot bot barr# #) }
193 #else /* 411 and higher */
194 case (newByteArray# size s) of { (# s2#, barr# #) ->
195 (# s2#, MutableByteArray bot bot barr# #) }
198 bot = error "new_ps_array"
200 #if __GLASGOW_HASKELL__ < 400
201 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
202 case writeCharArray# barr# n ch s# of { s2# ->
204 #elif __GLASGOW_HASKELL__ < 405
205 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
206 case writeCharArray# barr# n ch s# of { s2# ->
209 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
210 case writeCharArray# barr# n ch s# of { s2# ->
214 -- same as unsafeFreezeByteArray
215 #if __GLASGOW_HASKELL__ < 400
216 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
217 case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
218 STret s2# (ByteArray (0,I# len#) frozen#) }
219 #elif __GLASGOW_HASKELL__ < 405
220 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
221 case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
222 (# s2#, ByteArray (0,I# len#) frozen# #) }
224 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
225 case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
226 (# s2#, ByteArray 0 (I# len#) frozen# #) }
231 Compare two equal-length strings for equality:
234 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
235 eqStrPrefix a# barr# len# =
237 #if __GLASGOW_HASKELL__ < 405
238 _ccall_ strncmp (A# a#) (ByteArray bot barr#) (I# len#) >>= \ (I# x#) ->
240 _ccall_ strncmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) ->
244 #if __GLASGOW_HASKELL__ < 405
249 bot = error "eqStrPrefix"
251 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
252 eqCharStrPrefix a1# a2# len# =
254 _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
257 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
258 eqStrPrefixBA b1# b2# start# len# =
260 _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
261 #if __GLASGOW_HASKELL__ < 405
264 (ByteArray bot bot b2#)
267 #if __GLASGOW_HASKELL__ < 405
270 (ByteArray bot bot b1#)
272 (I# len#) >>= \ (I# x#) ->
275 #if __GLASGOW_HASKELL__ < 405
280 bot = error "eqStrPrefixBA"
282 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
283 eqCharStrPrefixBA a# b2# start# len# =
285 _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
286 #if __GLASGOW_HASKELL__ < 405
289 (ByteArray bot bot b2#)
293 (I# len#) >>= \ (I# x#) ->
296 #if __GLASGOW_HASKELL__ < 405
301 bot = error "eqCharStrPrefixBA"
303 eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
304 eqStrPrefixFO fo# barr# start# len# =
306 _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
309 #if __GLASGOW_HASKELL__ < 405
310 (ByteArray bot barr#)
312 (ByteArray bot bot barr#)
314 (I# len#) >>= \ (I# x#) ->
317 #if __GLASGOW_HASKELL__ < 405
322 bot = error "eqStrPrefixFO"