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