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