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 #else
 191     case (newCharArray# size s)   of { (# s2#, barr# #) ->
 192     (# s2#, MutableByteArray bot bot barr# #) }
 193 #endif
 194   where
 195     bot = error "new_ps_array"
 196
 197 #if __GLASGOW_HASKELL__ < 400
 198 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
 199     case writeCharArray# barr# n ch s#  of { s2#   ->
 200     STret s2# () }
 201 #elif __GLASGOW_HASKELL__ < 405
 202 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
 203     case writeCharArray# barr# n ch s#  of { s2#   ->
 204     (# s2#, () #) }
 205 #else
 206 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
 207     case writeCharArray# barr# n ch s#  of { s2#   ->
 208     (# s2#, () #) }
 209 #endif
 210
 211 -- same as unsafeFreezeByteArray
 212 #if __GLASGOW_HASKELL__ < 400
 213 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
 214     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 215     STret s2# (ByteArray (0,I# len#) frozen#) }
 216 #elif __GLASGOW_HASKELL__ < 405
 217 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
 218     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 219     (# s2#, ByteArray (0,I# len#) frozen# #) }
 220 #else
 221 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
 222     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 223     (# s2#, ByteArray 0 (I# len#) frozen# #) }
 224 #endif
 225 \end{code}
 226
 227
 228 Compare two equal-length strings for equality:
 229
 230 \begin{code}
 231 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 232 eqStrPrefix a# barr# len# =
 233   unsafePerformIO (
 234 #if __GLASGOW_HASKELL__ < 405
 235    _ccall_ strncmp (A# a#) (ByteArray bot barr#) (I# len#) >>= \ (I# x#) ->
 236 #else
 237    _ccall_ strncmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) ->
 238 #endif
 239    return (x# ==# 0#))
 240   where
 241 #if __GLASGOW_HASKELL__ < 405
 242    bot :: (Int,Int)
 243 #else
 244    bot :: Int
 245 #endif
 246    bot = error "eqStrPrefix"
 247
 248 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 249 eqCharStrPrefix a1# a2# len# =
 250   unsafePerformIO (
 251    _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
 252    return (x# ==# 0#))
 253
 254 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 255 eqStrPrefixBA b1# b2# start# len# =
 256   unsafePerformIO (
 257    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 258 #if __GLASGOW_HASKELL__ < 405
 259           (ByteArray bot b2#)
 260 #else
 261           (ByteArray bot bot b2#)
 262 #endif
 263           (I# start#)
 264 #if __GLASGOW_HASKELL__ < 405
 265           (ByteArray bot b1#)
 266 #else
 267           (ByteArray bot bot b1#)
 268 #endif
 269           (I# len#)                  >>= \ (I# x#) ->
 270    return (x# ==# 0#))
 271   where
 272 #if __GLASGOW_HASKELL__ < 405
 273    bot :: (Int,Int)
 274 #else
 275    bot :: Int
 276 #endif
 277    bot = error "eqStrPrefixBA"
 278
 279 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 280 eqCharStrPrefixBA a# b2# start# len# =
 281   unsafePerformIO (
 282    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 283 #if __GLASGOW_HASKELL__ < 405
 284           (ByteArray bot b2#)
 285 #else
 286           (ByteArray bot bot b2#)
 287 #endif
 288           (I# start#)
 289           (A# a#)
 290           (I# len#)                  >>= \ (I# x#) ->
 291    return (x# ==# 0#))
 292   where
 293 #if __GLASGOW_HASKELL__ < 405
 294    bot :: (Int,Int)
 295 #else
 296    bot :: Int
 297 #endif
 298    bot = error "eqCharStrPrefixBA"
 299
 300 eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
 301 eqStrPrefixFO fo# barr# start# len# =
 302   unsafePerformIO (
 303    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 304           (ForeignObj fo#)
 305           (I# start#)
 306 #if __GLASGOW_HASKELL__ < 405
 307           (ByteArray bot barr#)
 308 #else
 309           (ByteArray bot bot barr#)
 310 #endif
 311           (I# len#)                  >>= \ (I# x#) ->
 312    return (x# ==# 0#))
 313   where
 314 #if __GLASGOW_HASKELL__ < 405
 315    bot :: (Int,Int)
 316 #else
 317    bot :: Int
 318 #endif
 319    bot = error "eqStrPrefixFO"
 320 \end{code}