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