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