never executed always true always false

    1 {-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}
    2 -- | Efficient serialisation for GHCi Instruction arrays
    3 --
    4 -- Author: Ben Gamari
    5 --
    6 module GHCi.BinaryArray(putArray, getArray) where
    7 
    8 import Prelude
    9 import Foreign.Ptr
   10 import Data.Binary
   11 import Data.Binary.Put (putBuilder)
   12 import qualified Data.Binary.Get.Internal as Binary
   13 import qualified Data.ByteString.Builder as BB
   14 import qualified Data.ByteString.Builder.Internal as BB
   15 import qualified Data.Array.Base as A
   16 import qualified Data.Array.IO.Internals as A
   17 import qualified Data.Array.Unboxed as A
   18 import GHC.Exts
   19 import GHC.IO
   20 
   21 -- | An efficient serialiser of 'A.UArray'.
   22 putArray :: Binary i => A.UArray i a -> Put
   23 putArray (A.UArray l u _ arr#) = do
   24     put l
   25     put u
   26     putBuilder $ byteArrayBuilder arr#
   27 
   28 byteArrayBuilder :: ByteArray# -> BB.Builder
   29 byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))
   30   where
   31     go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
   32     go !inStart !inEnd k (BB.BufferRange outStart outEnd)
   33       -- There is enough room in this output buffer to write all remaining array
   34       -- contents
   35       | inRemaining <= outRemaining = do
   36           copyByteArrayToAddr arr# inStart outStart inRemaining
   37           k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)
   38       -- There is only enough space for a fraction of the remaining contents
   39       | otherwise = do
   40           copyByteArrayToAddr arr# inStart outStart outRemaining
   41           let !inStart' = inStart + outRemaining
   42           return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)
   43       where
   44         inRemaining  = inEnd - inStart
   45         outRemaining = outEnd `minusPtr` outStart
   46 
   47     copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
   48     copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =
   49         IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of
   50                      s' -> (# s', () #)
   51 
   52 -- | An efficient deserialiser of 'A.UArray'.
   53 getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)
   54 getArray = do
   55     l <- get
   56     u <- get
   57     arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-
   58         return $ unsafeDupablePerformIO $ A.newArray_ (l,u)
   59     let go 0 _ = return ()
   60         go !remaining !off = do
   61             Binary.readNWith n $ \ptr ->
   62               copyAddrToByteArray ptr arr# off n
   63             go (remaining - n) (off + n)
   64           where n = min chunkSize remaining
   65     go (I# (sizeofMutableByteArray# arr#)) 0
   66     return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr
   67   where
   68     chunkSize = 10*1024
   69 
   70     copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
   71                         -> Int -> Int -> IO ()
   72     copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =
   73         IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of
   74                      s' -> (# s', () #)
   75 
   76 -- this is inexplicably not exported in currently released array versions
   77 unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)
   78 unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)