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