ghc/compiler/utils/PrimPacked.lhs

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