ghc/compiler/utils/PrimPacked.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
   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 #include "HsVersions.h"
  12
  13 module PrimPacked
  14        (
  15         strLength,          -- :: _Addr -> Int
  16         copyPrefixStr,      -- :: _Addr -> Int -> _ByteArray Int
  17         copySubStr,         -- :: _Addr -> Int -> Int -> _ByteArray Int
  18         copySubStrFO,       -- :: ForeignObj -> Int -> Int -> _ByteArray Int
  19         copySubStrBA,       -- :: _ByteArray Int -> Int -> Int -> _ByteArray Int
  20
  21 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
  22         stringToByteArray,  -- :: String -> _ByteArray Int
  23         byteArrayToString,  -- :: _ByteArray Int -> String
  24 #endif
  25
  26         eqStrPrefix,        -- :: Addr# -> ByteArray# -> Int# -> Bool
  27         eqCharStrPrefix,    -- :: Addr# -> Addr# -> Int# -> Bool
  28         eqStrPrefixBA,      -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
  29         eqCharStrPrefixBA,  -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
  30         eqStrPrefixFO,      -- :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
  31
  32         addrOffset#,        -- :: Addr# -> Int# -> Addr#
  33         indexCharOffFO#     -- :: ForeignObj# -> Int# -> Char#
  34        ) where
  35
  36 #if __GLASGOW_HASKELL__ <= 201
  37 import PreludeGlaST
  38 import PreludeGlaMisc
  39 #else
  40 import GlaExts
  41 import Foreign
  42 import GHC
  43 import ArrBase
  44 import ST
  45 import STBase
  46
  47 # if __GLASGOW_HASKELL__ == 202
  48 import PrelBase ( Char(..) )
  49 # endif
  50
  51 # if __GLASGOW_HASKELL__ >= 206
  52 import PackBase
  53 # endif
  54
  55 #endif
  56
  57 \end{code}
  58
  59 Return the length of a @\\NUL@ terminated character string:
  60
  61 \begin{code}
  62 strLength :: _Addr -> Int
  63 strLength a =
  64  unsafePerformPrimIO (
  65     _ccall_ strlen a  `thenPrimIO` \ len@(I# _) ->
  66     returnPrimIO len
  67  )
  68
  69 \end{code}
  70
  71 Copying a char string prefix into a byte array,
  72 {\em assuming} the prefix does not contain any
  73 NULs.
  74
  75 \begin{code}
  76 copyPrefixStr :: _Addr -> Int -> _ByteArray Int
  77 copyPrefixStr (A# a) len@(I# length#) =
  78  unsafePerformPrimIO (
  79   {- allocate an array that will hold the string
  80     (not forgetting the NUL at the end)
  81   -}
  82   (new_ps_array (length# +# 1#))             `thenPrimIO` \ ch_array ->
  83 {- Revert back to Haskell-only solution for the moment.
  84    _ccall_ memcpy ch_array (A# a) len        `thenPrimIO`  \ () ->
  85    write_ps_array ch_array length# (chr# 0#) `seqPrimIO`
  86 -}
  87    -- fill in packed string from "addr"
  88   fill_in ch_array 0#                        `seqPrimIO`
  89    -- freeze the puppy:
  90   freeze_ps_array ch_array)
  91   where
  92     fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
  93
  94     fill_in arr_in# idx
  95       | idx ==# length#
  96       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
  97         returnStrictlyST ()
  98       | otherwise
  99       = case (indexCharOffAddr# a idx) of { ch ->
 100         write_ps_array arr_in# idx ch `seqStrictlyST`
 101         fill_in arr_in# (idx +# 1#) }
 102
 103 \end{code}
 104
 105 Copying out a substring, assume a 0-indexed string:
 106 (and positive lengths, thank you).
 107
 108 \begin{code}
 109 copySubStr :: _Addr -> Int -> Int -> _ByteArray Int
 110 copySubStr a start length =
 111   unsafePerformPrimIO (
 112     _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
 113                                                      `thenPrimIO` \ a_start ->
 114     returnPrimIO (copyPrefixStr a_start length))
 115 \end{code}
 116
 117 Copying a sub-string out of a ForeignObj
 118
 119 \begin{code}
 120 copySubStrFO :: _ForeignObj -> Int -> Int -> _ByteArray Int
 121 copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) =
 122  unsafePerformPrimIO (
 123   {- allocate an array that will hold the string
 124     (not forgetting the NUL at the end)
 125   -}
 126   new_ps_array (length# +# 1#)  `thenStrictlyST` \ ch_array ->
 127    -- fill in packed string from "addr"
 128   fill_in ch_array 0#   `seqStrictlyST`
 129    -- freeze the puppy:
 130   freeze_ps_array ch_array)
 131   where
 132     fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
 133
 134     fill_in arr_in# idx
 135       | idx ==# length#
 136       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 137         returnStrictlyST ()
 138       | otherwise
 139       = case (indexCharOffFO# fo (idx +# start#)) of { ch ->
 140         write_ps_array arr_in# idx ch `seqStrictlyST`
 141         fill_in arr_in# (idx +# 1#) }
 142
 143 {- ToDo: add FO primitives.. -}
 144 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <=205
 145 indexCharOffFO# :: ForeignObj# -> Int# -> Char#
 146 indexCharOffFO# fo# i# =
 147   case unsafePerformPrimIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (_ForeignObj fo#) (I# i#)) of
 148     C# c -> c
 149 #else
 150 indexCharOffFO# :: ForeignObj# -> Int# -> Char#
 151 indexCharOffFO# fo i = indexCharOffForeignObj# fo i
 152 #endif
 153
 154 -- step on (char *) pointer by x units.
 155 addrOffset# :: Addr# -> Int# -> Addr#
 156 addrOffset# a# i# =
 157   case unsafePerformPrimIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
 158     A# a -> a
 159
 160 copySubStrBA :: _ByteArray Int -> Int -> Int -> _ByteArray Int
 161 copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# length#) =
 162  unsafePerformPrimIO (
 163   {- allocate an array that will hold the string
 164     (not forgetting the NUL at the end)
 165   -}
 166   new_ps_array (length# +# 1#)  `thenStrictlyST` \ ch_array ->
 167    -- fill in packed string from "addr"
 168   fill_in ch_array 0#   `seqStrictlyST`
 169    -- freeze the puppy:
 170   freeze_ps_array ch_array)
 171   where
 172     fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
 173
 174     fill_in arr_in# idx
 175       | idx ==# length#
 176       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 177         returnStrictlyST ()
 178       | otherwise
 179       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
 180         write_ps_array arr_in# idx ch `seqStrictlyST`
 181         fill_in arr_in# (idx +# 1#) }
 182
 183 \end{code}
 184
 185 (Very :-) ``Specialised'' versions of some CharArray things...
 186
 187 \begin{code}
 188 new_ps_array    :: Int# -> _ST s (_MutableByteArray s Int)
 189 write_ps_array  :: _MutableByteArray s Int -> Int# -> Char# -> _ST s ()
 190 freeze_ps_array :: _MutableByteArray s Int -> _ST s (_ByteArray Int)
 191
 192 new_ps_array size =
 193     MkST ( \ (S# s) ->
 194     case (newCharArray# size s)   of { StateAndMutableByteArray# s2# barr# ->
 195     (_MutableByteArray (0, max 0 (I# (size -# 1#))) barr#, S# s2#)})
 196
 197 write_ps_array (_MutableByteArray _ barr#) n ch =
 198     MkST ( \ (S# s#) ->
 199     case writeCharArray# barr# n ch s#  of { s2#   ->
 200     ((), S# s2#)})
 201
 202 -- same as unsafeFreezeByteArray
 203 freeze_ps_array (_MutableByteArray ixs arr#) =
 204     MkST ( \ (S# s#) ->
 205     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 206     (_ByteArray ixs frozen#, S# s2#) })
 207 \end{code}
 208
 209 Compare two equal-length strings for equality:
 210
 211 \begin{code}
 212 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 213 eqStrPrefix a# barr# len# =
 214   unsafePerformPrimIO (
 215    _ccall_ strncmp (A# a#) (_ByteArray bottom barr#) (I# len#) `thenPrimIO` \ (I# x#) ->
 216    returnPrimIO (x# ==# 0#))
 217   where
 218    bottom :: (Int,Int)
 219    bottom = error "eqStrPrefix"
 220
 221 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 222 eqCharStrPrefix a1# a2# len# =
 223   unsafePerformPrimIO (
 224    _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) `thenPrimIO` \ (I# x#) ->
 225    returnPrimIO (x# ==# 0#))
 226   where
 227    bottom :: (Int,Int)
 228    bottom = error "eqStrPrefix"
 229
 230 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 231 eqStrPrefixBA b1# b2# start# len# =
 232   unsafePerformPrimIO (
 233    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 234           (_ByteArray bottom b2#)
 235           (I# start#)
 236           (_ByteArray bottom b1#)
 237           (I# len#)                  `thenPrimIO` \ (I# x#) ->
 238    returnPrimIO (x# ==# 0#))
 239   where
 240    bottom :: (Int,Int)
 241    bottom = error "eqStrPrefixBA"
 242
 243 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 244 eqCharStrPrefixBA a# b2# start# len# =
 245   unsafePerformPrimIO (
 246    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 247           (_ByteArray bottom b2#)
 248           (I# start#)
 249           (A# a#)
 250           (I# len#)                  `thenPrimIO` \ (I# x#) ->
 251    returnPrimIO (x# ==# 0#))
 252   where
 253    bottom :: (Int,Int)
 254    bottom = error "eqCharStrPrefixBA"
 255
 256 eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
 257 eqStrPrefixFO fo# barr# start# len# =
 258   unsafePerformPrimIO (
 259    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 260           (_ForeignObj fo#)
 261           (I# start#)
 262           (_ByteArray bottom barr#)
 263           (I# len#)                  `thenPrimIO` \ (I# x#) ->
 264    returnPrimIO (x# ==# 0#))
 265   where
 266    bottom :: (Int,Int)
 267    bottom = error "eqStrPrefixFO"
 268 \end{code}
 269
 270 \begin{code}
 271 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
 272 byteArrayToString :: _ByteArray Int -> String
 273 byteArrayToString (_ByteArray (I# start#,I# end#) barr#) =
 274  unpack start#
 275  where
 276   unpack nh#
 277    | nh# >=# end# = []
 278    | otherwise    = C# ch : unpack (nh# +# 1#)
 279      where
 280       ch = indexCharArray# barr# nh#
 281 #elif defined(__GLASGOW_HASKELL__)
 282 byteArrayToString :: _ByteArray Int -> String
 283 byteArrayToString = unpackCStringBA
 284 #else
 285 #error "byteArrayToString: cannot handle this!"
 286 #endif
 287
 288 \end{code}
 289
 290
 291 \begin{code}
 292 stringToByteArray :: String -> (_ByteArray Int)
 293 #if __GLASGOW_HASKELL__ >= 206
 294 stringToByteArray = packString
 295 #elif defined(__GLASGOW_HASKELL__)
 296 stringToByteArray str = _runST (packStringST str)
 297
 298 packStringST :: [Char] -> _ST s (_ByteArray Int)
 299 packStringST str =
 300   let len = length str  in
 301   packNCharsST len str
 302
 303 packNCharsST :: Int -> [Char] -> _ST s (_ByteArray Int)
 304 packNCharsST len@(I# length#) str =
 305   {-
 306    allocate an array that will hold the string
 307    (not forgetting the NUL byte at the end)
 308   -}
 309  new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
 310    -- fill in packed string from "str"
 311  fill_in ch_array 0# str      `seqStrictlyST`
 312    -- freeze the puppy:
 313  freeze_ps_array ch_array     `thenStrictlyST` \ (_ByteArray _ frozen#) ->
 314  returnStrictlyST (_ByteArray (0,len) frozen#)
 315  where
 316   fill_in :: _MutableByteArray s Int -> Int# -> [Char] -> _ST s ()
 317   fill_in arr_in# idx [] =
 318    write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 319    returnStrictlyST ()
 320
 321   fill_in arr_in# idx (C# c : cs) =
 322    write_ps_array arr_in# idx c  `seqStrictlyST`
 323    fill_in arr_in# (idx +# 1#) cs
 324 #else
 325 #error "stringToByteArray: cannot handle this"
 326 #endif
 327
 328 \end{code}