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#           `thenStrictlyST` \ barr ->
  88   returnStrictlyST 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#) `seqStrictlyST`
  95         returnStrictlyST ()
  96       | otherwise
  97       = case (indexCharOffAddr# a idx) of { ch ->
  98         write_ps_array arr_in# idx ch `seqStrictlyST`
  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#)  `thenStrictlyST` \ ch_array ->
 125    -- fill in packed string from "addr"
 126   fill_in ch_array 0#   `seqStrictlyST`
 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#) `seqStrictlyST`
 135         returnStrictlyST ()
 136       | otherwise
 137       = case (indexCharOffForeignObj# fo (idx +# start#)) of { ch ->
 138         write_ps_array arr_in# idx ch `seqStrictlyST`
 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#)  `thenStrictlyST` \ ch_array ->
 158    -- fill in packed string from "addr"
 159   fill_in ch_array 0#           `seqStrictlyST`
 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#) `seqStrictlyST`
 168         returnStrictlyST ()
 169       | otherwise
 170       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
 171         write_ps_array arr_in# idx ch `seqStrictlyST`
 172         fill_in arr_in# (idx +# 1#) }
 173
 174 \end{code}
 175
 176 (Very :-) ``Specialised'' versions of some CharArray things...
 177 [Copied from PackBase; no real reason -- UGH]
 178
 179 \begin{code}
 180 new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
 181 write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
 182 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
 183
 184 new_ps_array size = ST $ \ s ->
 185 #if __GLASGOW_HASKELL__ < 400
 186     case (newCharArray# size s)   of { StateAndMutableByteArray# s2# barr# ->
 187     STret s2# (MutableByteArray bot barr#) }
 188 #elif __GLASGOW_HASKELL__ < 405
 189     case (newCharArray# size s)   of { (# s2#, barr# #) ->
 190     (# s2#, MutableByteArray bot barr# #) }
 191 #else
 192     case (newCharArray# size s)   of { (# s2#, barr# #) ->
 193     (# s2#, MutableByteArray bot bot barr# #) }
 194 #endif
 195   where
 196     bot = error "new_ps_array"
 197
 198 #if __GLASGOW_HASKELL__ < 400
 199 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
 200     case writeCharArray# barr# n ch s#  of { s2#   ->
 201     STret s2# () }
 202 #elif __GLASGOW_HASKELL__ < 405
 203 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
 204     case writeCharArray# barr# n ch s#  of { s2#   ->
 205     (# s2#, () #) }
 206 #else
 207 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
 208     case writeCharArray# barr# n ch s#  of { s2#   ->
 209     (# s2#, () #) }
 210 #endif
 211
 212 -- same as unsafeFreezeByteArray
 213 #if __GLASGOW_HASKELL__ < 400
 214 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
 215     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 216     STret s2# (ByteArray (0,I# len#) frozen#) }
 217 #elif __GLASGOW_HASKELL__ < 405
 218 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
 219     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 220     (# s2#, ByteArray (0,I# len#) frozen# #) }
 221 #else
 222 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
 223     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 224     (# s2#, ByteArray 0 (I# len#) frozen# #) }
 225 #endif
 226 \end{code}
 227
 228
 229 Compare two equal-length strings for equality:
 230
 231 \begin{code}
 232 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 233 eqStrPrefix a# barr# len# =
 234   unsafePerformIO (
 235 #if __GLASGOW_HASKELL__ < 405
 236    _ccall_ strncmp (A# a#) (ByteArray bot barr#) (I# len#) >>= \ (I# x#) ->
 237 #else
 238    _ccall_ strncmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) ->
 239 #endif
 240    return (x# ==# 0#))
 241   where
 242 #if __GLASGOW_HASKELL__ < 405
 243    bot :: (Int,Int)
 244 #else
 245    bot :: Int
 246 #endif
 247    bot = error "eqStrPrefix"
 248
 249 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 250 eqCharStrPrefix a1# a2# len# =
 251   unsafePerformIO (
 252    _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
 253    return (x# ==# 0#))
 254
 255 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 256 eqStrPrefixBA b1# b2# start# len# =
 257   unsafePerformIO (
 258    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 259 #if __GLASGOW_HASKELL__ < 405
 260           (ByteArray bot b2#)
 261 #else
 262           (ByteArray bot bot b2#)
 263 #endif
 264           (I# start#)
 265 #if __GLASGOW_HASKELL__ < 405
 266           (ByteArray bot b1#)
 267 #else
 268           (ByteArray bot bot b1#)
 269 #endif
 270           (I# len#)                  >>= \ (I# x#) ->
 271    return (x# ==# 0#))
 272   where
 273 #if __GLASGOW_HASKELL__ < 405
 274    bot :: (Int,Int)
 275 #else
 276    bot :: Int
 277 #endif
 278    bot = error "eqStrPrefixBA"
 279
 280 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 281 eqCharStrPrefixBA a# b2# start# len# =
 282   unsafePerformIO (
 283    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 284 #if __GLASGOW_HASKELL__ < 405
 285           (ByteArray bot b2#)
 286 #else
 287           (ByteArray bot bot b2#)
 288 #endif
 289           (I# start#)
 290           (A# a#)
 291           (I# len#)                  >>= \ (I# x#) ->
 292    return (x# ==# 0#))
 293   where
 294 #if __GLASGOW_HASKELL__ < 405
 295    bot :: (Int,Int)
 296 #else
 297    bot :: Int
 298 #endif
 299    bot = error "eqCharStrPrefixBA"
 300
 301 eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
 302 eqStrPrefixFO fo# barr# start# len# =
 303   unsafePerformIO (
 304    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 305           (ForeignObj fo#)
 306           (I# start#)
 307 #if __GLASGOW_HASKELL__ < 405
 308           (ByteArray bot barr#)
 309 #else
 310           (ByteArray bot bot barr#)
 311 #endif
 312           (I# len#)                  >>= \ (I# x#) ->
 313    return (x# ==# 0#))
 314   where
 315 #if __GLASGOW_HASKELL__ < 405
 316    bot :: (Int,Int)
 317 #else
 318    bot :: Int
 319 #endif
 320    bot = error "eqStrPrefixFO"
 321 \end{code}