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