ghc/lib/std/PrelPack.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997
   3 %
   4 \section[PrelPack]{Packing/unpacking bytes}
   5
   6 This module provides a small set of low-level functions for packing
   7 and unpacking a chunk of bytes. Used by code emitted by the compiler
   8 plus the prelude libraries.
   9
  10 The programmer level view of packed strings is provided by a GHC
  11 system library PackedString.
  12
  13 \begin{code}
  14 {-# OPTIONS -fno-implicit-prelude #-}
  15
  16 module PrelPack
  17        (
  18         -- (**) - emitted by compiler.
  19
  20         packCString#,      -- :: [Char] -> ByteArray#  **
  21         packString,        -- :: [Char] -> ByteArray Int
  22         packStringST,      -- :: [Char] -> ST s (ByteArray Int)
  23         packNBytesST,      -- :: Int -> [Char] -> ST s (ByteArray Int)
  24
  25         unpackCString,     -- :: Addr -> [Char]
  26         unpackCStringST,   -- :: Addr -> ST s [Char]
  27         unpackNBytes,      -- :: Addr -> Int -> [Char]
  28         unpackNBytesST,    -- :: Addr -> Int -> ST s [Char]
  29         unpackNBytesAccST, -- :: Addr -> Int -> [Char] -> ST s [Char]
  30         unpackCString#,    -- :: Addr# -> [Char]         **
  31         unpackNBytes#,     -- :: Addr# -> Int# -> [Char] **
  32         unpackNBytesST#,   -- :: Addr# -> Int# -> ST s [Char]
  33
  34         unpackCStringBA,   -- :: ByteArray Int -> [Char]
  35         unpackNBytesBA,    -- :: ByteArray Int -> Int  -> [Char]
  36         unpackCStringBA#,  -- :: ByteArray#    -> Int# -> [Char]
  37         unpackNBytesBA#,   -- :: ByteArray#    -> Int# -> [Char]
  38
  39
  40         unpackFoldrCString#,  -- **
  41         unpackAppendCString#,  -- **
  42
  43         new_ps_array,           -- Int# -> ST s (MutableByteArray s Int)
  44         write_ps_array,         -- MutableByteArray s Int -> Int# -> Char# -> ST s ()
  45         freeze_ps_array         -- MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
  46
  47        )
  48         where
  49
  50 import PrelBase
  51 import {-# SOURCE #-} PrelErr ( error )
  52 import PrelList ( length )
  53 import PrelST
  54 import PrelNum
  55 import PrelArr
  56 import PrelByteArr
  57 import PrelAddr
  58
  59 \end{code}
  60
  61 %*********************************************************
  62 %*                                                      *
  63 \subsection{Unpacking Addrs}
  64 %*                                                      *
  65 %*********************************************************
  66
  67 Primitives for converting Addrs pointing to external
  68 sequence of bytes into a list of @Char@s:
  69
  70 \begin{code}
  71 unpackCString  :: Addr{- ptr. to NUL terminated string-} -> [Char]
  72 unpackCString a@(A# addr)
  73   | a == nullAddr  = []
  74   | otherwise      = unpackCString# addr
  75
  76 unpackCStringST  :: Addr{- ptr. to NUL terminated string-} -> ST s [Char]
  77 unpackCStringST a@(A# addr)
  78   | a == nullAddr  = return []
  79   | otherwise      = unpack 0#
  80   where
  81     unpack nh
  82       | ch `eqChar#` '\0'# = return []
  83       | otherwise          = do
  84                 ls <- unpack (nh +# 1#)
  85                 return ((C# ch ) : ls)
  86       where
  87         ch = indexCharOffAddr# addr nh
  88
  89 unpackCString# :: Addr#  -> [Char]
  90 unpackCString# addr
  91   = unpack 0#
  92   where
  93     unpack nh
  94       | ch `eqChar#` '\0'# = []
  95       | otherwise          = C# ch : unpack (nh +# 1#)
  96       where
  97         ch = indexCharOffAddr# addr nh
  98
  99 unpackNBytes :: Addr -> Int -> [Char]
 100 unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l
 101
 102 unpackNBytesST :: Addr -> Int -> ST s [Char]
 103 unpackNBytesST (A# addr) (I# l) = unpackNBytesAccST# addr l []
 104
 105 unpackNBytesAccST :: Addr -> Int -> [Char] -> ST s [Char]
 106 unpackNBytesAccST (A# addr) (I# l) rest = unpackNBytesAccST# addr l rest
 107
 108 unpackNBytes#      :: Addr# -> Int#   -> [Char]
 109   -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
 110   -- It's strict!
 111 unpackNBytes# _addr 0#   = []
 112 unpackNBytes#  addr len# = unpack [] (len# -# 1#)
 113     where
 114      unpack acc i#
 115       | i# <# 0#  = acc
 116       | otherwise =
 117          case indexCharOffAddr# addr i# of
 118             ch -> unpack (C# ch : acc) (i# -# 1#)
 119
 120 unpackNBytesST# :: Addr# -> Int# -> ST s [Char]
 121 unpackNBytesST# addr# l#   = unpackNBytesAccST# addr# l# []
 122
 123 unpackNBytesAccST# :: Addr# -> Int# -> [Char] -> ST s [Char]
 124 unpackNBytesAccST# _addr 0#   rest = return rest
 125 unpackNBytesAccST#  addr len# rest = unpack rest (len# -# 1#)
 126   where
 127     unpack acc i#
 128       | i# <# 0#  = return acc
 129       | otherwise  =
 130          case indexCharOffAddr# addr i# of
 131           ch -> unpack (C# ch : acc) (i# -# 1#)
 132
 133 \end{code}
 134
 135 %********************************************************
 136 %*                                                      *
 137 \subsection{Unpacking ByteArrays}
 138 %*                                                      *
 139 %********************************************************
 140
 141 Converting byte arrays into list of chars:
 142
 143 \begin{code}
 144 unpackCStringBA :: ByteArray Int -> [Char]
 145 unpackCStringBA (ByteArray l@(I# l#) u@(I# u#) bytes)
 146  | l > u     = []
 147  | otherwise = unpackCStringBA# bytes (u# -# l# +# 1#)
 148
 149 {-
 150  unpack until NUL or end of BA is reached, whatever comes first.
 151 -}
 152 unpackCStringBA# :: ByteArray# -> Int# -> [Char]
 153 unpackCStringBA# bytes len
 154  = unpack 0#
 155  where
 156     unpack nh
 157       | nh >=# len         ||
 158         ch `eqChar#` '\0'#    = []
 159       | otherwise             = C# ch : unpack (nh +# 1#)
 160       where
 161         ch = indexCharArray# bytes nh
 162
 163 unpackNBytesBA :: ByteArray Int -> Int -> [Char]
 164 unpackNBytesBA (ByteArray l u bytes) i
 165  = unpackNBytesBA# bytes len#
 166    where
 167     len# = case max 0 (min i len) of I# v# -> v#
 168     len | l > u     = 0
 169         | otherwise = u-l+1
 170
 171 unpackNBytesBA# :: ByteArray# -> Int# -> [Char]
 172 unpackNBytesBA# _bytes 0#   = []
 173 unpackNBytesBA#  bytes len# = unpack [] (len# -# 1#)
 174    where
 175     unpack acc i#
 176      | i# <# 0#  = acc
 177      | otherwise =
 178           case indexCharArray# bytes i# of
 179             ch -> unpack (C# ch : acc) (i# -# 1#)
 180
 181 \end{code}
 182
 183
 184 %********************************************************
 185 %*                                                      *
 186 \subsection{Packing Strings}
 187 %*                                                      *
 188 %********************************************************
 189
 190 Converting a list of chars into a packed @ByteArray@ representation.
 191
 192 \begin{code}
 193 packCString#         :: [Char]          -> ByteArray#
 194 packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes }
 195
 196 packString :: [Char] -> ByteArray Int
 197 packString str = runST (packStringST str)
 198
 199 packStringST :: [Char] -> ST s (ByteArray Int)
 200 packStringST str =
 201   let len = length str  in
 202   packNBytesST len str
 203
 204 packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)
 205 packNBytesST (I# length#) str =
 206   {-
 207    allocate an array that will hold the string
 208    (not forgetting the NUL byte at the end)
 209   -}
 210  new_ps_array (length# +# 1#) >>= \ ch_array ->
 211    -- fill in packed string from "str"
 212  fill_in ch_array 0# str   >>
 213    -- freeze the puppy:
 214  freeze_ps_array ch_array length#
 215  where
 216   fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
 217   fill_in arr_in# idx [] =
 218    write_ps_array arr_in# idx (chr# 0#) >>
 219    return ()
 220
 221   fill_in arr_in# idx (C# c : cs) =
 222    write_ps_array arr_in# idx c  >>
 223    fill_in arr_in# (idx +# 1#) cs
 224
 225 \end{code}
 226
 227 (Very :-) ``Specialised'' versions of some CharArray things...
 228
 229 \begin{code}
 230 new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
 231 write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
 232 freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
 233
 234 new_ps_array size = ST $ \ s ->
 235     case (newCharArray# size s)   of { (# s2#, barr# #) ->
 236     (# s2#, MutableByteArray bot bot barr# #) }
 237   where
 238     bot = error "new_ps_array"
 239
 240 write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
 241     case writeCharArray# barr# n ch s#  of { s2#   ->
 242     (# s2#, () #) }
 243
 244 -- same as unsafeFreezeByteArray
 245 freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
 246     case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
 247     (# s2#, ByteArray 0 (I# len#) frozen# #) }
 248 \end{code}
 249
 250
 251 %********************************************************
 252 %*                                                      *
 253 \subsection{Misc}
 254 %*                                                      *
 255 %********************************************************
 256
 257 The compiler may emit these two
 258
 259 \begin{code}
 260 unpackAppendCString# :: Addr# -> [Char] -> [Char]
 261 unpackAppendCString# addr rest
 262   = unpack 0#
 263   where
 264     unpack nh
 265       | ch `eqChar#` '\0'# = rest
 266       | otherwise          = C# ch : unpack (nh +# 1#)
 267       where
 268         ch = indexCharOffAddr# addr nh
 269
 270 unpackFoldrCString#  :: Addr# -> (Char  -> a -> a) -> a -> a
 271 unpackFoldrCString# addr f z
 272   = unpack 0#
 273   where
 274     unpack nh
 275       | ch `eqChar#` '\0'# = z
 276       | otherwise          = C# ch `f` unpack (nh +# 1#)
 277       where
 278         ch = indexCharOffAddr# addr nh
 279 \end{code}