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
11 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
14 Ptr(..), nullPtr, writeCharOffPtr, plusAddr#,
16 packString, -- :: String -> (Int, BA)
17 unpackCStringBA, -- :: BA -> Int -> [Char]
18 strLength, -- :: Ptr CChar -> Int
19 copyPrefixStr, -- :: Addr# -> Int -> BA
20 copySubStr, -- :: Addr# -> Int -> Int -> BA
21 copySubStrBA, -- :: BA -> Int -> Int -> BA
22 eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
23 eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
24 eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
25 eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
28 -- This #define suppresses the "import FastString" that
29 -- HsVersions otherwise produces
30 #define COMPILING_FAST_STRING
31 #include "HsVersions.h"
34 import UNSAFE_IO ( unsafePerformIO )
39 #if __GLASGOW_HASKELL__ < 503
45 #if __GLASGOW_HASKELL__ >= 504
46 import GHC.Ptr ( Ptr(..) )
47 #elif __GLASGOW_HASKELL__ >= 500
48 import Ptr ( Ptr(..) )
51 #if __GLASGOW_HASKELL__ < 504
52 import PrelIOBase ( IO(..) )
54 import GHC.IOBase ( IO(..) )
58 Compatibility: 4.08 didn't have the Ptr type.
61 #if __GLASGOW_HASKELL__ <= 408
62 data Ptr a = Ptr Addr# deriving (Eq, Ord)
65 nullPtr = Ptr (int2Addr# 0#)
68 #if __GLASGOW_HASKELL__ <= 500
69 -- plusAddr# is a primop in GHC > 5.00
70 plusAddr# :: Addr# -> Int# -> Addr#
71 plusAddr# a# i# = int2Addr# (addr2Int# a# +# i#)
74 -- more compatibility: in 5.00+ we would use the Storable class for this,
75 -- but 4.08 doesn't have it.
76 writeCharOffPtr (Ptr a#) (I# i#) (C# c#) = IO $ \s# ->
77 case writeCharOffAddr# a# i# c# s# of { s# -> (# s#, () #) }
80 Wrapper types for bytearrays
83 data BA = BA ByteArray#
84 data MBA s = MBA (MutableByteArray# s)
88 packString :: String -> (Int, BA)
89 packString str = (l, arr)
91 l@(I# length#) = length str
94 ch_array <- new_ps_array (length# +# 1#)
95 -- fill in packed string from "str"
96 fill_in ch_array 0# str
98 freeze_ps_array ch_array length#
101 fill_in :: MBA s -> Int# -> [Char] -> ST s ()
102 fill_in arr_in# idx [] =
103 write_ps_array arr_in# idx (chr# 0#) >>
106 fill_in arr_in# idx (C# c : cs) =
107 write_ps_array arr_in# idx c >>
108 fill_in arr_in# (idx +# 1#) cs
114 unpackCStringBA :: BA -> Int -> [Char]
115 unpackCStringBA (BA bytes) (I# len)
120 ch `eqChar#` '\0'# = []
121 | otherwise = C# ch : unpack (nh +# 1#)
123 ch = indexCharArray# bytes nh
126 Copying a char string prefix into a byte array,
127 {\em assuming} the prefix does not contain any
131 copyPrefixStr :: Addr# -> Int -> BA
132 copyPrefixStr a# len@(I# length#) = copy' length#
134 copy' length# = runST (do
135 {- allocate an array that will hold the string
136 (not forgetting the NUL at the end)
138 ch_array <- new_ps_array (length# +# 1#)
139 {- Revert back to Haskell-only solution for the moment.
140 _ccall_ memcpy ch_array (A# a) len >>= \ () ->
141 write_ps_array ch_array length# (chr# 0#) >>
143 -- fill in packed string from "addr"
146 freeze_ps_array ch_array length#
149 fill_in :: MBA s -> Int# -> ST s ()
152 = write_ps_array arr_in# idx (chr# 0#) >>
155 = case (indexCharOffAddr# a# idx) of { ch ->
156 write_ps_array arr_in# idx ch >>
157 fill_in arr_in# (idx +# 1#) }
160 Copying out a substring, assume a 0-indexed string:
161 (and positive lengths, thank you).
164 copySubStr :: Addr# -> Int -> Int -> BA
165 copySubStr a# (I# start#) length =
166 copyPrefixStr (a# `plusAddr#` start#) length
168 copySubStrBA :: BA -> Int -> Int -> BA
169 copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
172 {- allocate an array that will hold the string
173 (not forgetting the NUL at the end)
175 ch_array <- new_ps_array (length# +# 1#)
176 -- fill in packed string from "addr"
179 freeze_ps_array ch_array length#
182 fill_in :: MBA s -> Int# -> ST s ()
185 = write_ps_array arr_in# idx (chr# 0#) >>
188 = case (indexCharArray# barr# (start# +# idx)) of { ch ->
189 write_ps_array arr_in# idx ch >>
190 fill_in arr_in# (idx +# 1#) }
193 (Very :-) ``Specialised'' versions of some CharArray things...
194 [Copied from PackBase; no real reason -- UGH]
197 new_ps_array :: Int# -> ST s (MBA s)
198 write_ps_array :: MBA s -> Int# -> Char# -> ST s ()
199 freeze_ps_array :: MBA s -> Int# -> ST s BA
201 #if __GLASGOW_HASKELL__ < 411
202 #define NEW_BYTE_ARRAY newCharArray#
204 #define NEW_BYTE_ARRAY newByteArray#
207 new_ps_array size = ST $ \ s ->
208 case (NEW_BYTE_ARRAY size s) of { (# s2#, barr# #) ->
209 (# s2#, MBA barr# #) }
211 write_ps_array (MBA barr#) n ch = ST $ \ s# ->
212 case writeCharArray# barr# n ch s# of { s2# ->
215 -- same as unsafeFreezeByteArray
216 freeze_ps_array (MBA arr#) len# = ST $ \ s# ->
217 case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
218 (# s2#, BA frozen# #) }
222 Compare two equal-length strings for equality:
225 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
226 eqStrPrefix a# barr# len# =
228 x <- memcmp_ba a# barr# (I# len#)
232 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
233 eqCharStrPrefix a1# a2# len# =
235 x <- memcmp a1# a2# (I# len#)
238 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
239 eqStrPrefixBA b1# b2# start# len# =
241 x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
244 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
245 eqCharStrPrefixBA a# b2# start# len# =
247 x <- memcmp_baoff b2# (I# start#) a# (I# len#)
252 #if __GLASGOW_HASKELL__ <= 408
253 strLength (Ptr a#) = ghc_strlen a#
254 foreign import ccall "ghc_strlen" unsafe
255 ghc_strlen :: Addr# -> Int
257 foreign import ccall "ghc_strlen" unsafe
258 strLength :: Ptr () -> Int
261 foreign import ccall "ghc_memcmp" unsafe
262 memcmp :: Addr# -> Addr# -> Int -> IO Int
264 foreign import ccall "ghc_memcmp" unsafe
265 memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
267 foreign import ccall "ghc_memcmp_off" unsafe
268 memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int
270 foreign import ccall "ghc_memcmp_off" unsafe
271 memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int