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