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