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