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