[project @ 2000-06-29 13:08:59 by simonmar]
[ghc-hetmet.git] / ghc / compiler / utils / PrimPacked.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
3 %
4 \section{Basic ops on packed representations}
5
6 Some basic operations for working on packed representations of series
7 of bytes (character strings). Used by the interface lexer input
8 subsystem, mostly.
9
10 \begin{code}
11 module PrimPacked
12        (
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
18
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
24
25         addrOffset#         -- :: Addr# -> Int# -> Addr# 
26        ) where
27
28 -- This #define suppresses the "import FastString" that
29 -- HsVersions otherwise produces
30 #define COMPILING_FAST_STRING
31 #include "HsVersions.h"
32
33 import GlaExts
34 import PrelAddr ( Addr(..) )
35 import ST
36 import Foreign
37 -- ForeignObj is now exported abstractly.
38 #if __GLASGOW_HASKELL__ >= 303
39 import PrelForeign   ( ForeignObj(..) )
40 #endif
41
42 #if __GLASGOW_HASKELL__ < 301
43 import ArrBase          ( StateAndMutableByteArray#(..), 
44                           StateAndByteArray#(..) )
45 import STBase
46 #elif __GLASGOW_HASKELL__ < 400
47 import PrelArr          ( StateAndMutableByteArray#(..), 
48                           StateAndByteArray#(..) )
49 import PrelST
50 #else
51 import PrelST
52 #endif
53
54 \end{code} 
55
56 Return the length of a @\\NUL@ terminated character string:
57
58 \begin{code}
59 strLength :: Addr -> Int
60 strLength a =
61  unsafePerformIO (
62     _ccall_ strlen a  >>= \ len@(I# _) ->
63     return len
64  )
65 {-# NOINLINE strLength #-}
66 \end{code}
67
68 Copying a char string prefix into a byte array,
69 {\em assuming} the prefix does not contain any
70 NULs.
71
72 \begin{code}
73 copyPrefixStr :: Addr -> Int -> ByteArray Int
74 copyPrefixStr (A# a) len@(I# length#) =
75  runST (
76   {- allocate an array that will hold the string
77     (not forgetting the NUL at the end)
78   -}
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#) >>
83 -}
84    -- fill in packed string from "addr"
85   fill_in ch_array 0#                        >>
86    -- freeze the puppy:
87   freeze_ps_array ch_array length#           `thenStrictlyST` \ barr ->
88   returnStrictlyST barr )
89   where
90     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
91
92     fill_in arr_in# idx
93       | idx ==# length#
94       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
95         returnStrictlyST ()
96       | otherwise
97       = case (indexCharOffAddr# a idx) of { ch ->
98         write_ps_array arr_in# idx ch `seqStrictlyST`
99         fill_in arr_in# (idx +# 1#) }
100
101 \end{code}
102
103 Copying out a substring, assume a 0-indexed string:
104 (and positive lengths, thank you).
105
106 \begin{code}
107 copySubStr :: Addr -> Int -> Int -> ByteArray Int
108 copySubStr a start length =
109   unsafePerformIO (
110     _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start 
111                                                      >>= \ a_start ->
112     return (copyPrefixStr a_start length))
113 \end{code}
114
115 pCopying a sub-string out of a ForeignObj
116
117 \begin{code}
118 copySubStrFO :: ForeignObj -> Int -> Int -> ByteArray Int
119 copySubStrFO (ForeignObj fo) (I# start#) len@(I# length#) =
120  runST (
121   {- allocate an array that will hold the string
122     (not forgetting the NUL at the end)
123   -}
124   new_ps_array (length# +# 1#)  `thenStrictlyST` \ ch_array ->
125    -- fill in packed string from "addr"
126   fill_in ch_array 0#   `seqStrictlyST`
127    -- freeze the puppy:
128   freeze_ps_array ch_array length#)
129   where
130     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
131
132     fill_in arr_in# idx
133       | idx ==# length#
134       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
135         returnStrictlyST ()
136       | otherwise
137       = case (indexCharOffForeignObj# fo (idx +# start#)) of { ch ->
138         write_ps_array arr_in# idx ch `seqStrictlyST`
139         fill_in arr_in# (idx +# 1#) }
140
141 -- step on (char *) pointer by x units.
142 addrOffset# :: Addr# -> Int# -> Addr# 
143 addrOffset# a# i# =
144   case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
145     A# a -> a
146
147 copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
148 #if __GLASGOW_HASKELL__ >= 405
149 copySubStrBA (ByteArray _ _ barr#) (I# start#) len@(I# length#) =
150 #else
151 copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) =
152 #endif
153  runST (
154   {- allocate an array that will hold the string
155     (not forgetting the NUL at the end)
156   -}
157   new_ps_array (length# +# 1#)  `thenStrictlyST` \ ch_array ->
158    -- fill in packed string from "addr"
159   fill_in ch_array 0#           `seqStrictlyST`
160    -- freeze the puppy:
161   freeze_ps_array ch_array length#)
162   where
163     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
164
165     fill_in arr_in# idx
166       | idx ==# length#
167       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
168         returnStrictlyST ()
169       | otherwise
170       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
171         write_ps_array arr_in# idx ch `seqStrictlyST`
172         fill_in arr_in# (idx +# 1#) }
173
174 \end{code}
175
176 (Very :-) ``Specialised'' versions of some CharArray things...
177 [Copied from PackBase; no real reason -- UGH]
178
179 \begin{code}
180 new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
181 write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s () 
182 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
183
184 new_ps_array size = ST $ \ s ->
185 #if __GLASGOW_HASKELL__ < 400
186     case (newCharArray# size s)   of { StateAndMutableByteArray# s2# barr# ->
187     STret s2# (MutableByteArray bot barr#) }
188 #elif __GLASGOW_HASKELL__ < 405
189     case (newCharArray# size s)   of { (# s2#, barr# #) ->
190     (# s2#, MutableByteArray bot barr# #) }
191 #else
192     case (newCharArray# size s)   of { (# s2#, barr# #) ->
193     (# s2#, MutableByteArray bot bot barr# #) }
194 #endif
195   where
196     bot = error "new_ps_array"
197
198 #if __GLASGOW_HASKELL__ < 400
199 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
200     case writeCharArray# barr# n ch s#  of { s2#   ->
201     STret s2# () }
202 #elif __GLASGOW_HASKELL__ < 405
203 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
204     case writeCharArray# barr# n ch s#  of { s2#   ->
205     (# s2#, () #) }
206 #else
207 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
208     case writeCharArray# barr# n ch s#  of { s2#   ->
209     (# s2#, () #) }
210 #endif
211
212 -- same as unsafeFreezeByteArray
213 #if __GLASGOW_HASKELL__ < 400
214 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
215     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
216     STret s2# (ByteArray (0,I# len#) frozen#) }
217 #elif __GLASGOW_HASKELL__ < 405
218 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
219     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
220     (# s2#, ByteArray (0,I# len#) frozen# #) }
221 #else
222 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
223     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
224     (# s2#, ByteArray 0 (I# len#) frozen# #) }
225 #endif
226 \end{code}
227
228
229 Compare two equal-length strings for equality:
230
231 \begin{code}
232 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
233 eqStrPrefix a# barr# len# = 
234   unsafePerformIO (
235 #if __GLASGOW_HASKELL__ < 405
236    _ccall_ strncmp (A# a#) (ByteArray bot barr#) (I# len#) >>= \ (I# x#) ->
237 #else
238    _ccall_ strncmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) ->
239 #endif
240    return (x# ==# 0#))
241   where
242 #if __GLASGOW_HASKELL__ < 405
243    bot :: (Int,Int)
244 #else
245    bot :: Int
246 #endif
247    bot = error "eqStrPrefix"
248
249 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
250 eqCharStrPrefix a1# a2# len# = 
251   unsafePerformIO (
252    _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
253    return (x# ==# 0#))
254
255 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
256 eqStrPrefixBA b1# b2# start# len# = 
257   unsafePerformIO (
258    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' 
259 #if __GLASGOW_HASKELL__ < 405
260           (ByteArray bot b2#)
261 #else
262           (ByteArray bot bot b2#) 
263 #endif 
264           (I# start#) 
265 #if __GLASGOW_HASKELL__ < 405
266           (ByteArray bot b1#) 
267 #else
268           (ByteArray bot bot b1#) 
269 #endif
270           (I# len#)                  >>= \ (I# x#) ->
271    return (x# ==# 0#))
272   where
273 #if __GLASGOW_HASKELL__ < 405
274    bot :: (Int,Int)
275 #else
276    bot :: Int
277 #endif
278    bot = error "eqStrPrefixBA"
279
280 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
281 eqCharStrPrefixBA a# b2# start# len# = 
282   unsafePerformIO (
283    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' 
284 #if __GLASGOW_HASKELL__ < 405
285           (ByteArray bot b2#) 
286 #else
287           (ByteArray bot bot b2#) 
288 #endif
289           (I# start#) 
290           (A# a#)
291           (I# len#)                  >>= \ (I# x#) ->
292    return (x# ==# 0#))
293   where
294 #if __GLASGOW_HASKELL__ < 405
295    bot :: (Int,Int)
296 #else
297    bot :: Int
298 #endif
299    bot = error "eqCharStrPrefixBA"
300
301 eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
302 eqStrPrefixFO fo# barr# start# len# = 
303   unsafePerformIO (
304    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' 
305           (ForeignObj fo#) 
306           (I# start#) 
307 #if __GLASGOW_HASKELL__ < 405
308           (ByteArray bot barr#) 
309 #else
310           (ByteArray bot bot barr#) 
311 #endif
312           (I# len#)                  >>= \ (I# x#) ->
313    return (x# ==# 0#))
314   where
315 #if __GLASGOW_HASKELL__ < 405
316    bot :: (Int,Int)
317 #else
318    bot :: Int
319 #endif
320    bot = error "eqStrPrefixFO"
321 \end{code}