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         unpackNBytesBA,    -- :: 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#
  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    return ()
 104   fill_in arr_in# idx (C# c : cs) =
 105    write_ps_array arr_in# idx c  >>
 106    fill_in arr_in# (idx +# 1#) cs
 107 \end{code}
 108
 109 Unpacking a string
 110
 111 \begin{code}
 112 unpackNBytesBA :: BA -> Int -> [Char]
 113 unpackNBytesBA (BA bytes) (I# len)
 114  = unpack 0#
 115  where
 116     unpack nh
 117       | nh >=# len  = []
 118       | otherwise   = C# ch : unpack (nh +# 1#)
 119       where
 120         ch = indexCharArray# bytes nh
 121 \end{code}
 122
 123 Copying a char string prefix into a byte array.
 124
 125 \begin{code}
 126 copyPrefixStr :: Addr# -> Int -> BA
 127 copyPrefixStr a# len@(I# length#) = copy' length#
 128  where
 129    copy' length# = runST (do
 130      {- allocate an array that will hold the string
 131      -}
 132      ch_array <- new_ps_array length#
 133      {- Revert back to Haskell-only solution for the moment.
 134         _ccall_ memcpy ch_array (A# a) len        >>=  \ () ->
 135         write_ps_array ch_array length# (chr# 0#) >>
 136      -}
 137      -- fill in packed string from "addr"
 138      fill_in ch_array 0#
 139      -- freeze the puppy:
 140      freeze_ps_array ch_array length#
 141     )
 142
 143    fill_in :: MBA s -> Int# -> ST s ()
 144    fill_in arr_in# idx
 145       | idx ==# length#
 146       = return ()
 147       | otherwise
 148       = case (indexCharOffAddr# a# idx) of { ch ->
 149         write_ps_array arr_in# idx ch >>
 150         fill_in arr_in# (idx +# 1#) }
 151 \end{code}
 152
 153 Copying out a substring, assume a 0-indexed string:
 154 (and positive lengths, thank you).
 155
 156 \begin{code}
 157 copySubStr :: Addr# -> Int -> Int -> BA
 158 copySubStr a# (I# start#) length =
 159   copyPrefixStr (a# `plusAddr#` start#)  length
 160
 161 copySubStrBA :: BA -> Int -> Int -> BA
 162 copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
 163  where
 164   ba = runST (do
 165      -- allocate an array that will hold the string
 166     ch_array <- new_ps_array length#
 167      -- fill in packed string from "addr"
 168     fill_in ch_array 0#
 169      -- freeze the puppy:
 170     freeze_ps_array ch_array length#
 171    )
 172
 173   fill_in :: MBA s -> Int# -> ST s ()
 174   fill_in arr_in# idx
 175       | idx ==# length#
 176       = return ()
 177       | otherwise
 178       = case (indexCharArray# barr# (start# +# idx)) of { ch ->
 179         write_ps_array arr_in# idx ch >>
 180         fill_in arr_in# (idx +# 1#) }
 181 \end{code}
 182
 183 (Very :-) ``Specialised'' versions of some CharArray things...
 184 [Copied from PackBase; no real reason -- UGH]
 185
 186 \begin{code}
 187 new_ps_array    :: Int# -> ST s (MBA s)
 188 write_ps_array  :: MBA s -> Int# -> Char# -> ST s ()
 189 freeze_ps_array :: MBA s -> Int# -> ST s BA
 190
 191 #if __GLASGOW_HASKELL__ < 411
 192 #define NEW_BYTE_ARRAY newCharArray#
 193 #else
 194 #define NEW_BYTE_ARRAY newByteArray#
 195 #endif
 196
 197 new_ps_array size = ST $ \ s ->
 198     case (NEW_BYTE_ARRAY size s)  of { (# s2#, barr# #) ->
 199     (# s2#, MBA barr# #) }
 200
 201 write_ps_array (MBA barr#) n ch = ST $ \ s# ->
 202     case writeCharArray# barr# n ch s#  of { s2#   ->
 203     (# s2#, () #) }
 204
 205 -- same as unsafeFreezeByteArray
 206 freeze_ps_array (MBA arr#) len# = ST $ \ s# ->
 207     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 208     (# s2#, BA frozen# #) }
 209 \end{code}
 210
 211
 212 Compare two equal-length strings for equality:
 213
 214 \begin{code}
 215 eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
 216 eqStrPrefix a# barr# len# =
 217   unsafePerformIO $ do
 218    x <- memcmp_ba a# barr# (I# len#)
 219    return (x == 0)
 220
 221 -- unused???
 222 eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
 223 eqCharStrPrefix a1# a2# len# =
 224   unsafePerformIO $ do
 225    x <- memcmp a1# a2# (I# len#)
 226    return (x == 0)
 227
 228 eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
 229 eqStrPrefixBA b1# b2# start# len# =
 230   unsafePerformIO $ do
 231     x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
 232     return (x == 0)
 233
 234 eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
 235 eqCharStrPrefixBA a# b2# start# len# =
 236   unsafePerformIO $ do
 237     x <- memcmp_baoff b2# (I# start#) a# (I# len#)
 238     return (x == 0)
 239 \end{code}
 240
 241 \begin{code}
 242 #if __GLASGOW_HASKELL__ <= 408
 243 strLength (Ptr a#) = ghc_strlen a#
 244 foreign import ccall "ghc_strlen" unsafe
 245   ghc_strlen :: Addr# -> Int
 246 #else
 247 foreign import ccall "ghc_strlen" unsafe
 248   strLength :: Ptr () -> Int
 249 #endif
 250
 251 foreign import ccall "ghc_memcmp" unsafe
 252   memcmp :: Addr# -> Addr# -> Int -> IO Int
 253
 254 foreign import ccall "ghc_memcmp" unsafe
 255   memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
 256
 257 foreign import ccall "ghc_memcmp_off" unsafe
 258   memcmp_baoff :: ByteArray# -> Int -> Addr# -> Int -> IO Int
 259
 260 foreign import ccall "ghc_memcmp_off" unsafe
 261   memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int
 262 \end{code}