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