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