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