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 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
  12
  13 module PrimPacked (
  14         Ptr(..), nullPtr, writeCharOffPtr, plusAddr#,
  15         BA(..), MBA(..),
  16         packString,        -- :: String -> (Int, BA)
  17         unpackCStringBA,   -- :: BA -> Int -> [Char]
  18         strLength,         -- :: Ptr CChar -> Int
  19         copyPrefixStr,     -- :: Addr# -> Int -> BA
  20         copySubStr,        -- :: Addr# -> Int -> Int -> BA
  21         copySubStrBA,      -- :: BA -> Int -> Int -> BA
  22         eqStrPrefix,       -- :: Addr# -> ByteArray# -> Int# -> Bool
  23         eqCharStrPrefix,   -- :: Addr# -> Addr# -> Int# -> Bool
  24         eqStrPrefixBA,     -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
  25         eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
  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 UNSAFE_IO        ( unsafePerformIO )
  35
  36 import MONAD_ST
  37 import Foreign
  38
  39 #if __GLASGOW_HASKELL__ < 503
  40 import PrelST
  41 #else
  42 import GHC.ST
  43 #endif
  44
  45 #if __GLASGOW_HASKELL__ >= 504
  46 import GHC.Ptr  ( Ptr(..) )
  47 #elif __GLASGOW_HASKELL__ >= 500
  48 import Ptr      ( Ptr(..) )
  49 #endif
  50
  51 #if __GLASGOW_HASKELL__ < 504
  52 import PrelIOBase       ( IO(..) )
  53 #else
  54 import GHC.IOBase       ( IO(..) )
  55 #endif
  56 \end{code}
  57
  58 Compatibility: 4.08 didn't have the Ptr type.
  59
  60 \begin{code}
  61 #if __GLASGOW_HASKELL__ <= 408
  62 data Ptr a = Ptr Addr# deriving (Eq, Ord)
  63
  64 nullPtr :: Ptr a
  65 nullPtr = Ptr (int2Addr# 0#)
  66 #endif
  67
  68 #if __GLASGOW_HASKELL__ <= 500
  69 -- plusAddr# is a primop in GHC > 5.00
  70 plusAddr# :: Addr# -> Int# -> Addr#
  71 plusAddr# a# i# = int2Addr# (addr2Int# a# +# i#)
  72 #endif
  73
  74 -- more compatibility: in 5.00+ we would use the Storable class for this,
  75 -- but 4.08 doesn't have it.
  76 writeCharOffPtr (Ptr a#) (I# i#) (C# c#) = IO $ \s# ->
  77   case writeCharOffAddr# a# i# c# s# of { s# -> (# s#, () #) }
  78 \end{code}
  79
  80 Wrapper types for bytearrays
  81
  82 \begin{code}
  83 data BA    = BA  ByteArray#
  84 data MBA s = MBA (MutableByteArray# s)
  85 \end{code}
  86
  87 \begin{code}
  88 packString :: String -> (Int, BA)
  89 packString str = (l, arr)
  90  where
  91   l@(I# length#) = length str
  92
  93   arr = runST (do
  94     ch_array <- new_ps_array (length# +# 1#)
  95       -- fill in packed string from "str"
  96     fill_in ch_array 0# str
  97       -- freeze the puppy:
  98     freeze_ps_array ch_array length#
  99    )
 100
 101   fill_in :: MBA s -> Int# -> [Char] -> ST s ()
 102   fill_in arr_in# idx [] =
 103    write_ps_array arr_in# idx (chr# 0#) >>
 104    return ()
 105
 106   fill_in arr_in# idx (C# c : cs) =
 107    write_ps_array arr_in# idx c  >>
 108    fill_in arr_in# (idx +# 1#) cs
 109 \end{code}
 110
 111 Unpacking a string
 112
 113 \begin{code}
 114 unpackCStringBA :: BA -> Int -> [Char]
 115 unpackCStringBA (BA bytes) (I# len)
 116  = unpack 0#
 117  where
 118     unpack nh
 119       | nh >=# len         ||
 120         ch `eqChar#` '\0'#    = []
 121       | otherwise             = C# ch : unpack (nh +# 1#)
 122       where
 123         ch = indexCharArray# bytes nh
 124 \end{code}
 125
 126 Copying a char string prefix into a byte array,
 127 {\em assuming} the prefix does not contain any
 128 NULs.
 129
 130 \begin{code}
 131 copyPrefixStr :: Addr# -> Int -> BA
 132 copyPrefixStr a# len@(I# length#) = copy' length#
 133  where
 134    copy' length# = runST (do
 135      {- allocate an array that will hold the string
 136        (not forgetting the NUL at the end)
 137      -}
 138      ch_array <- new_ps_array (length# +# 1#)
 139      {- Revert back to Haskell-only solution for the moment.
 140         _ccall_ memcpy ch_array (A# a) len        >>=  \ () ->
 141         write_ps_array ch_array length# (chr# 0#) >>
 142      -}
 143      -- fill in packed string from "addr"
 144      fill_in ch_array 0#
 145      -- freeze the puppy:
 146      freeze_ps_array ch_array length#
 147     )
 148
 149    fill_in :: MBA s -> Int# -> ST s ()
 150    fill_in arr_in# idx
 151       | idx ==# length#
 152       = write_ps_array arr_in# idx (chr# 0#) >>
 153         return ()
 154       | otherwise
 155       = case (indexCharOffAddr# a# idx) of { ch ->
 156         write_ps_array arr_in# idx ch >>
 157         fill_in arr_in# (idx +# 1#) }
 158 \end{code}
 159
 160 Copying out a substring, assume a 0-indexed string:
 161 (and positive lengths, thank you).
 162
 163 \begin{code}
 164 copySubStr :: Addr# -> Int -> Int -> BA
 165 copySubStr a# (I# start#) length =
 166   copyPrefixStr (a# `plusAddr#` start#)  length
 167
 168 copySubStrBA :: BA -> Int -> Int -> BA
 169 copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
 170  where
 171   ba = runST (do
 172     {- allocate an array that will hold the string
 173       (not forgetting the NUL at the end)
 174     -}
 175     ch_array <- new_ps_array (length# +# 1#)
 176      -- fill in packed string from "addr"
 177     fill_in ch_array 0#
 178      -- freeze the puppy:
 179     freeze_ps_array ch_array length#
 180    )
 181
 182   fill_in :: MBA s -> Int# -> ST s ()
 183   fill_in arr_in# idx
 184       | idx ==# length#
 185       = write_ps_array arr_in# idx (chr# 0#) >>
 186         return ()
 187       | otherwise
 188       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
 189         write_ps_array arr_in# idx ch >>
 190         fill_in arr_in# (idx +# 1#) }
 191 \end{code}
 192
 193 (Very :-) ``Specialised'' versions of some CharArray things...
 194 [Copied from PackBase; no real reason -- UGH]
 195
 196 \begin{code}
 197 new_ps_array    :: Int# -> ST s (MBA s)
 198 write_ps_array  :: MBA s -> Int# -> Char# -> ST s ()
 199 freeze_ps_array :: MBA s -> Int# -> ST s BA
 200
 201 #if __GLASGOW_HASKELL__ < 411
 202 #define NEW_BYTE_ARRAY newCharArray#
 203 #else
 204 #define NEW_BYTE_ARRAY newByteArray#
 205 #endif
 206
 207 new_ps_array size = ST $ \ s ->
 208     case (NEW_BYTE_ARRAY size s)  of { (# s2#, barr# #) ->
 209     (# s2#, MBA barr# #) }
 210
 211 write_ps_array (MBA barr#) n ch = ST $ \ s# ->
 212     case writeCharArray# barr# n ch s#  of { s2#   ->
 213     (# s2#, () #) }
 214
 215 -- same as unsafeFreezeByteArray
 216 freeze_ps_array (MBA arr#) len# = ST $ \ s# ->
 217     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 218     (# s2#, BA frozen# #) }
 219 \end{code}
 220
 221
 222 Compare two equal-length strings for equality:
 223
 224 \begin{code}
 225 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 226 eqStrPrefix a# barr# len# =
 227   unsafePerformIO $ do
 228    x <- memcmp_ba a# barr# (I# len#)
 229    return (x == 0)
 230
 231 -- unused???
 232 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 233 eqCharStrPrefix a1# a2# len# =
 234   unsafePerformIO $ do
 235    x <- memcmp a1# a2# (I# len#)
 236    return (x == 0)
 237
 238 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 239 eqStrPrefixBA b1# b2# start# len# =
 240   unsafePerformIO $ do
 241     x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
 242     return (x == 0)
 243
 244 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 245 eqCharStrPrefixBA a# b2# start# len# =
 246   unsafePerformIO $ do
 247     x <- memcmp_baoff b2# (I# start#) a# (I# len#)
 248     return (x == 0)
 249 \end{code}
 250
 251 \begin{code}
 252 #if __GLASGOW_HASKELL__ <= 408
 253 strLength (Ptr a#) = ghc_strlen a#
 254 foreign import ccall "ghc_strlen" unsafe
 255   ghc_strlen :: Addr# -> Int
 256 #else
 257 foreign import ccall "ghc_strlen" unsafe
 258   strLength :: Ptr () -> Int
 259 #endif
 260
 261 foreign import ccall "ghc_memcmp" unsafe
 262   memcmp :: Addr# -> Addr# -> Int -> IO Int
 263
 264 foreign import ccall "ghc_memcmp" unsafe
 265   memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
 266
 267 foreign import ccall "ghc_memcmp_off" unsafe
 268   memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int
 269
 270 foreign import ccall "ghc_memcmp_off" unsafe
 271   memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int
 272 \end{code}