ghc/compiler/utils/PrimPacked.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
   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 Addr     ( 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 #else
  47 import PrelArr          ( StateAndMutableByteArray#(..),
  48                           StateAndByteArray#(..) )
  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
  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#           `thenStrictlyST` \ barr ->
  86   returnStrictlyST 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#) `seqStrictlyST`
  93         returnStrictlyST ()
  94       | otherwise
  95       = case (indexCharOffAddr# a idx) of { ch ->
  96         write_ps_array arr_in# idx ch `seqStrictlyST`
  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 \end{code}
 112
 113 pCopying a sub-string out of a ForeignObj
 114
 115 \begin{code}
 116 copySubStrFO :: ForeignObj -> Int -> Int -> ByteArray Int
 117 copySubStrFO (ForeignObj fo) (I# start#) len@(I# length#) =
 118  runST (
 119   {- allocate an array that will hold the string
 120     (not forgetting the NUL at the end)
 121   -}
 122   new_ps_array (length# +# 1#)  `thenStrictlyST` \ ch_array ->
 123    -- fill in packed string from "addr"
 124   fill_in ch_array 0#   `seqStrictlyST`
 125    -- freeze the puppy:
 126   freeze_ps_array ch_array length#)
 127   where
 128     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 129
 130     fill_in arr_in# idx
 131       | idx ==# length#
 132       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 133         returnStrictlyST ()
 134       | otherwise
 135       = case (indexCharOffForeignObj# fo (idx +# start#)) of { ch ->
 136         write_ps_array arr_in# idx ch `seqStrictlyST`
 137         fill_in arr_in# (idx +# 1#) }
 138
 139 -- step on (char *) pointer by x units.
 140 addrOffset# :: Addr# -> Int# -> Addr#
 141 addrOffset# a# i# =
 142   case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
 143     A# a -> a
 144
 145 copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
 146 copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) =
 147  runST (
 148   {- allocate an array that will hold the string
 149     (not forgetting the NUL at the end)
 150   -}
 151   new_ps_array (length# +# 1#)  `thenStrictlyST` \ ch_array ->
 152    -- fill in packed string from "addr"
 153   fill_in ch_array 0#           `seqStrictlyST`
 154    -- freeze the puppy:
 155   freeze_ps_array ch_array length#)
 156   where
 157     fill_in :: MutableByteArray s Int -> Int# -> ST s ()
 158
 159     fill_in arr_in# idx
 160       | idx ==# length#
 161       = write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
 162         returnStrictlyST ()
 163       | otherwise
 164       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
 165         write_ps_array arr_in# idx ch `seqStrictlyST`
 166         fill_in arr_in# (idx +# 1#) }
 167
 168 \end{code}
 169
 170 (Very :-) ``Specialised'' versions of some CharArray things...
 171 [Copied from PackBase; no real reason -- UGH]
 172
 173 \begin{code}
 174 new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
 175 write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
 176 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
 177
 178 new_ps_array size = ST $ \ s ->
 179     case (newCharArray# size s)   of { StateAndMutableByteArray# s2# barr# ->
 180     STret s2# (MutableByteArray bot barr#) }
 181   where
 182     bot = error "new_ps_array"
 183
 184 write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
 185     case writeCharArray# barr# n ch s#  of { s2#   ->
 186     STret s2# () }
 187
 188 -- same as unsafeFreezeByteArray
 189 freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
 190     case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
 191     STret s2# (ByteArray (0,I# len#) frozen#) }
 192 \end{code}
 193
 194
 195 Compare two equal-length strings for equality:
 196
 197 \begin{code}
 198 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 199 eqStrPrefix a# barr# len# =
 200   unsafePerformIO (
 201    _ccall_ strncmp (A# a#) (ByteArray bottom barr#) (I# len#) >>= \ (I# x#) ->
 202    return (x# ==# 0#))
 203   where
 204    bottom :: (Int,Int)
 205    bottom = error "eqStrPrefix"
 206
 207 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 208 eqCharStrPrefix a1# a2# len# =
 209   unsafePerformIO (
 210    _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
 211    return (x# ==# 0#))
 212
 213 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 214 eqStrPrefixBA b1# b2# start# len# =
 215   unsafePerformIO (
 216    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 217           (ByteArray bottom b2#)
 218           (I# start#)
 219           (ByteArray bottom b1#)
 220           (I# len#)                  >>= \ (I# x#) ->
 221    return (x# ==# 0#))
 222   where
 223    bottom :: (Int,Int)
 224    bottom = error "eqStrPrefixBA"
 225
 226 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 227 eqCharStrPrefixBA a# b2# start# len# =
 228   unsafePerformIO (
 229    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 230           (ByteArray bottom b2#)
 231           (I# start#)
 232           (A# a#)
 233           (I# len#)                  >>= \ (I# x#) ->
 234    return (x# ==# 0#))
 235   where
 236    bottom :: (Int,Int)
 237    bottom = error "eqCharStrPrefixBA"
 238
 239 eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
 240 eqStrPrefixFO fo# barr# start# len# =
 241   unsafePerformIO (
 242    _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
 243           (ForeignObj fo#)
 244           (I# start#)
 245           (ByteArray bottom barr#)
 246           (I# len#)                  >>= \ (I# x#) ->
 247    return (x# ==# 0#))
 248   where
 249    bottom :: (Int,Int)
 250    bottom = error "eqStrPrefixFO"
 251 \end{code}