ghc/compiler/utils/PrimPacked.lhs

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