halfs-0.2: Binary.hs
{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -#include <strings.h> #-}
{-# OPTIONS -#include "binutils.h" #-}
--
-- (c) The University of Glasgow 2002
--
-- Binary I/O library, with special tweaks for GHC
--
-- Based on the nhc98 Binary library, which is copyright
-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
-- Under the terms of the license for that software, we must tell you
-- where you can obtain the original version of the Binary library, namely
-- http://www.cs.york.ac.uk/fp/nhc98/
-- Unit tests by
-- Paul Steckler, NGIT/FNMOC, paul.steckler.ctr@metnet.navy.mil
-- fixme: who did the GHC port?
-- AJG: I believe it was Simon Marlow
--
-- the Sven Panne port is known to be buggy
-- The Binary module is *not* thread save. Only one threads should
-- be actively interacting with each Handle at a time.
module Binary
( BinHandle,
FixedBinHandle,
FixedSysHandle,
IOBinHandle,
BinaryHandle, -- abstract class
Binary(..),
Binary.copyBytes,
Bin(..),
BinArray,
tellBin,
seekBin,
openBinIO,
openBinMem,
openFixedBinMem,
openFixedSysHandle,
sizeBinMem,
sizeFixedBinMem,
sizeFixedSysMem,
zeroFixedBinHandle,
zeroFixedSysHandle,
resetBin,
copyMap,
invalidateFixedBinMem,
invalidateFixedSysMem,
) where
#include "ghcconfig.h"
#if 0
#include "haskell_debug.h"
#endif
import BinArray as BA
import FastMutInt
-- import GHC.IO
import Data.Array.SysArray
--import Data.Map(Map)
# if __GLASGOW_HASKELL__>=602
-- import Data.HashTable as HashTable
# endif
-- import Data.Array.IO
-- import Data.Array.Storable
import Data.Array
-- import Data.Bits
-- import Data.Int
-- import Data.Word
import Data.IORef
import Data.Char ( ord, chr )
-- import Data.Array.Base ( unsafeRead, unsafeWrite, bounds )
import Control.Monad ( when )
import Control.Exception ( assert )
import System.IO as IO
import System.Posix.IO (fdSeek, fdRead, fdWrite)
import System.Posix.Types (Fd(..))
-- import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
--import GHC.Real ( Ratio(..) )
import GHC.Exts
import GHC.IOBase ( IO(..) )
-- import GHC.Word ( Word8(..) )
-- import System.Directory ( removeFile )
# if __GLASGOW_HASKELL__<602
-- import GHC.Handle ( hSetBinaryMode )
# endif
import Foreign
import Foreign.C
-- for debug
--import System.CPUTime (getCPUTime)
-- import Numeric (showFFloat)
--import Testing
-- FIXME: we should really get SIZEOF_HSINT directly from ghc's config.h
#define SIZEOF_HSINT SIZEOF_VOID_P
-- This is a hack to prevent the profiling version from
-- being *significantly* slower than the unprofiling version.
--
#ifdef PROFILING
#define IOSCC(label,act) IO $ \ s -> {-# SCC label #-} case act of { IO m -> m s }
#else
#define IOSCC(label,act) act
#endif
-- type BinArray = StorableArray Int Word8
-- newtype BinArray = BinArray IOUArray Int Word8
---------------------------------------------------------------
-- BinHandle. etc
---------------------------------------------------------------
data IOBinHandle
= IOBinHandle {
io_off_r :: !FastMutInt, -- the current offset (cached)
hdl :: !Fd -- the file handle (must be seekable)
}
-- cache the file ptr in BinIO; using hTell is too expensive
-- to call repeatedly. If anyone else is modifying this Handle
-- at the same time, we'll be screwed.
data BinHandle
= BinMem { -- binary data stored in an unboxed array
off_r :: !FastMutInt, -- the current offset
sz_r :: !FastMutInt, -- size of the array (cached)
-- TODO: use the arr_r's size.
arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
}
data FixedBinHandle
= FixedBinMem { -- binary data stored in an unboxed array
f_off_r :: !FastMutInt, -- the current offset
f_sz_r :: !FastMutInt, -- size of the array (cached)
-- TODO: use the arr_r's size.
f_arr_r :: !BinArray -- the array (bounds: (0,size-1))
}
data FixedSysHandle
= FixedSysMem { -- binary data stored in an unboxed array
fs_off_r :: !FastMutInt, -- the current offset
fs_sz_r :: !FastMutInt, -- size of the array (cached)
-- TODO: use the arr_r's size.
fs_arr_r :: !(SysArray Word8) -- the array (bounds: (0,size-1))
}
---------------------------------------------------------------
-- Bin
---------------------------------------------------------------
newtype Bin a = BinPtr Int
deriving (Eq, Ord, Show, Bounded)
---------------------------------------------------------------
-- class BinaryHandle
---------------------------------------------------------------
class BinaryHandle m where
bhPut :: m -> Word8 -> IO ()
bhGet :: m -> IO Word8
tellBin :: m -> IO (Bin a)
seekBin :: m -> Bin a -> IO ()
getAddrRef :: m -> Int -> IO (Maybe AddrRef)
getAddrRef _ _ = return $ Nothing
-- |reset the pointer
resetBin :: (BinaryHandle m) => m -> IO ()
resetBin bh = seekBin bh (BinPtr 0)
---------------------------------------------------------------
-- class Binary
---------------------------------------------------------------
class Binary a where
put_ :: (BinaryHandle h) => h -> a -> IO ()
put :: (BinaryHandle h) => h -> a -> IO (Bin a)
get :: (BinaryHandle h) => h -> IO a
-- define one of put_, put. Use of put_ is recommended because it
-- is more likely that tail-calls can kick in, and we rarely need the
-- position return value.
put_ bh a = do put bh a; return ()
put bh a = do p <- tellBin bh; put_ bh a; return p
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
instance BinaryHandle BinHandle where
bhPut h@(BinMem ix_r sz_r arr_r) w = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
-- double the size of the array if it overflows
if (ix >= sz)
then do expandBin h ix
bhPut h w
else do arr <- readIORef arr_r
BA.writeWord8 arr ix w
writeFastMutInt ix_r (ix+1)
return ()
bhGet (BinMem ix_r sz_r arr_r) = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix >= sz) $
ioError (mkIOError eofErrorType ("Halfs.Binary.getWord8 array: " ++ (show sz) ++" ")
Nothing Nothing)
arr <- readIORef arr_r
w <- BA.readWord8 arr ix
writeFastMutInt ix_r (ix+1)
return w
tellBin (BinMem r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
seekBin h@(BinMem ix_r sz_r a) (BinPtr p) = do
sz <- readFastMutInt sz_r
if (p >= sz)
-- FIX: Below assertion is because we don't want any resizing in this app.
-- FIX: dont use this for fixed sized buffers.
then if (p > sz) then do expandBin h p; writeFastMutInt ix_r p
else -- at end of array, but that is legal, provided we do not read or write.
writeFastMutInt ix_r p
else writeFastMutInt ix_r p
getAddrRef h@(BinMem off_r sz_r arr_r_ref) count = do
-- move the pointer forward *first*
-- (this does bound checking or increases the size of the array),
ix <- readFastMutInt off_r
seekBin h (BinPtr (ix + count))
arr_r <- readIORef arr_r_ref
-- then move it back.
seekBin h (BinPtr ix)
return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr_r)
ix
(seekBin h (BinPtr (ix + count)))
-- openBinHandle :: BinArray -> IO BinHandle
-- openBinHandle arr = do
-- arr_r <- newIORef arr
-- ix_r <- newFastMutInt
-- writeFastMutInt ix_r 0
-- sz_r <- newFastMutInt
-- writeFastMutInt sz_r (sizeBinArray arr)
-- return (BinMem ix_r sz_r arr_r)
openBinMem :: Int -> IO BinHandle
openBinMem size
| size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0"
| otherwise = do
arr <- BA.newBinArray size
arr_r <- newIORef arr
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
sz_r <- newFastMutInt
writeFastMutInt sz_r size
return (BinMem ix_r sz_r arr_r)
sizeBinMem :: BinHandle -> IO Int
sizeBinMem (BinMem _ sz_r _) = readFastMutInt sz_r
-- getBinArray :: BinHandle -> IO BinArray
-- getBinArray (BinMem _ _ arr_r) = readIORef arr_r
-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
expandBin (BinMem ix_r sz_r arr_r) off = do
sz <- readFastMutInt sz_r
let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
arr <- readIORef arr_r
arr' <- newBinArray sz'
BA.copy arr arr'
writeFastMutInt sz_r sz'
writeIORef arr_r arr'
#ifdef DEBUG
hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
#endif
return ()
--expandBin (BinIO _ _) _ = return ()
-- no need to expand a file, we'll assume they expand by themselves.
---------------------------------------------------------------
-- FixedBinHandle
---------------------------------------------------------------
instance BinaryHandle FixedBinHandle where
bhPut h@(FixedBinMem ix_r sz_r arr) w = do
checkFixedBinMem h
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix >= sz) $
ioError (mkIOError eofErrorType ("Binary.bhPut FixedBinHandle: writing passed end of FixedBinHandle at " ++ (show sz) ++" ")
Nothing Nothing)
BA.writeWord8 arr ix w
writeFastMutInt ix_r (ix+1)
checkFixedBinMem h
return ()
bhGet h@(FixedBinMem ix_r sz_r arr) = do
checkFixedBinMem h
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix >= sz) $
ioError (mkIOError eofErrorType ("Binary.bhGet FixedBinHandle: reading passed end of FixedBinHandle at " ++ (show sz) ++" ")
Nothing Nothing)
w <- BA.readWord8 arr ix
writeFastMutInt ix_r (ix+1)
checkFixedBinMem h
return w
tellBin h@(FixedBinMem r _ _) = do checkFixedBinMem h ; ix <- readFastMutInt r; return (BinPtr ix)
seekBin h@(FixedBinMem ix_r sz_r a) (BinPtr p) = do
checkFixedBinMem h
sz <- readFastMutInt sz_r
when (p > sz) $
ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed end of FixedBinHandle at " ++ (show sz) ++" ")
Nothing Nothing)
when (p < 0) $
ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed start of FixedBinHandle at " ++ (show sz) ++" ")
Nothing Nothing)
writeFastMutInt ix_r p
checkFixedBinMem h
getAddrRef h@(FixedBinMem off_r sz_r arr) count = do
checkFixedBinMem h
-- move the pointer forward *first* to check bounds
ix <- readFastMutInt off_r
seekBin h (BinPtr (ix + count))
-- then move it back.
seekBin h (BinPtr ix)
checkFixedBinMem h
return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr)
ix
(seekBin h (BinPtr (ix + count)))
{-
openFixedBinHandle :: BinArray -> IO FixedBinHandle
openFixedBinHandle arr = do
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
sz_r <- newFastMutInt
writeFastMutInt sz_r (sizeBinArray arr)
return $ FixedBinMem ix_r sz_r arr
-}
checkFixedBinMem :: FixedBinHandle -> IO ()
checkFixedBinMem (FixedBinMem ix_r _ _) = do
ix <- readFastMutInt ix_r
assert (ix /= -1) $ return ()
-- |make a handle 'dead'. uses to test reclaiming strategies.
invalidateFixedBinMem :: FixedBinHandle -> IO ()
invalidateFixedBinMem (FixedBinMem ix_r _ _) = do
writeFastMutInt ix_r (-1)
return ()
openFixedBinMem :: Int -> IO FixedBinHandle
openFixedBinMem size
| size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0"
| otherwise = do
arr <- BA.newBinArray size
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
sz_r <- newFastMutInt
writeFastMutInt sz_r size
let h = FixedBinMem ix_r sz_r arr
checkFixedBinMem h
return $ h
sizeFixedBinMem :: FixedBinHandle -> IO Int
sizeFixedBinMem h@(FixedBinMem _ sz_r _) = do
checkFixedBinMem h
readFastMutInt sz_r
zeroFixedBinHandle :: FixedBinHandle -> IO ()
zeroFixedBinHandle h@(FixedBinMem ix_r _ arr) = do
checkFixedBinMem h
BA.zeroBinArray arr
writeFastMutInt ix_r 0
checkFixedBinMem h
return ()
---------------------------------------------------------------
-- FixedSysHandle
---------------------------------------------------------------
instance BinaryHandle FixedSysHandle where
bhPut h@(FixedSysMem ix_r sz_r arr) w = do
checkFixedSysMem h
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix >= sz) $
ioError (mkIOError eofErrorType ("Binary.bhPut FixedSysHandle: writing passed end of FixedSysHandle at " ++ (show sz) ++" ")
Nothing Nothing)
pokeSysArrayElem arr (fromIntegral ix) w
writeFastMutInt ix_r (ix+1)
checkFixedSysMem h
return ()
bhGet h@(FixedSysMem ix_r sz_r arr) = do
checkFixedSysMem h
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix >= sz) $
ioError (mkIOError eofErrorType ("Binary.bhGet FixedSysHandle: reading passed end of FixedSysHandle at " ++ (show sz) ++" ")
Nothing Nothing)
w <- peekSysArrayElem arr (fromIntegral ix)
writeFastMutInt ix_r (ix+1)
checkFixedSysMem h
return w
tellBin h@(FixedSysMem r _ _) = do checkFixedSysMem h ; ix <- readFastMutInt r; return (BinPtr ix)
seekBin h@(FixedSysMem ix_r sz_r a) (BinPtr p) = do
checkFixedSysMem h
sz <- readFastMutInt sz_r
when (p > sz) $
ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed end of FixedSysHandle at " ++ (show sz) ++" ")
Nothing Nothing)
when (p < 0) $
ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed start of FixedSysHandle at " ++ (show sz) ++" ")
Nothing Nothing)
writeFastMutInt ix_r p
checkFixedSysMem h
getAddrRef h@(FixedSysMem off_r sz_r arr) count = do
checkFixedSysMem h
-- move the pointer forward *first* to check bounds
ix <- readFastMutInt off_r
seekBin h (BinPtr (ix + count))
-- then move it back.
seekBin h (BinPtr ix)
checkFixedSysMem h
return $ Just $ SysArrAddrRef (ptrFromSysArray arr)
ix
(seekBin h (BinPtr (ix + count)))
openFixedSysHandle :: SysArray Word8 -> IO FixedSysHandle
openFixedSysHandle arr = do
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
sz_r <- newFastMutInt
writeFastMutInt sz_r (fromIntegral (sysArraySize arr))
return $ FixedSysMem ix_r sz_r arr
checkFixedSysMem :: FixedSysHandle -> IO ()
checkFixedSysMem (FixedSysMem ix_r _ _) = do
ix <- readFastMutInt ix_r
assert (ix /= -1) $ return ()
-- |make a handle 'dead'. uses to test reclaiming strategies.
invalidateFixedSysMem :: FixedSysHandle -> IO ()
invalidateFixedSysMem (FixedSysMem ix_r _ _) = do
writeFastMutInt ix_r (-1)
return ()
sizeFixedSysMem :: FixedSysHandle -> IO Int
sizeFixedSysMem h@(FixedSysMem _ sz_r _) = do
checkFixedSysMem h
readFastMutInt sz_r
foreign import ccall unsafe "binzero" binzero
:: Ptr Word8 -> CSize -> IO ()
zeroFixedSysHandle :: FixedSysHandle -> IO ()
zeroFixedSysHandle h@(FixedSysMem ix_r sz_r arr) = do
checkFixedSysMem h
sz <- readFastMutInt sz_r
binzero (ptrFromSysArray arr) (fromIntegral sz)
writeFastMutInt ix_r 0
checkFixedSysMem h
return ()
---------------------------------------------------------------
-- IOBinHandle
---------------------------------------------------------------
instance BinaryHandle IOBinHandle where
bhPut (IOBinHandle ix_r h) w = do
ix <- readFastMutInt ix_r
fdWrite h [(chr (fromIntegral w))] -- XXX not really correct
writeFastMutInt ix_r (ix+1)
return ()
bhGet (IOBinHandle ix_r h) = do
ix <- readFastMutInt ix_r
([c], count) <- fdRead h 1
writeFastMutInt ix_r (ix+1)
return $! (fromIntegral (ord c)) -- XXX not really correct
tellBin (IOBinHandle r _) = do
ix <- readFastMutInt r
return (BinPtr ix)
seekBin (IOBinHandle ix_r h) (BinPtr p) = do
writeFastMutInt ix_r p
-- print ("fdSeek: " , p)
fdSeek h AbsoluteSeek (fromIntegral p)
return ()
getAddrRef (IOBinHandle ix_r fd) count = do
return $ Just $ FdAddrRef
{ ch_fd = fd
, ch_done = do ix <- readFastMutInt ix_r
writeFastMutInt ix_r (ix + count)
}
openBinIO :: Fd -> IO IOBinHandle
openBinIO h = do
r <- newFastMutInt
writeFastMutInt r 0
return $ IOBinHandle r h
-- -----------------------------------------------------------------------------
-- Primitve Word writes
instance Binary Word8 where
put_ bh a = bhPut bh a
get = bhGet
instance Binary Word16 where
put_ h w = do
bhPut h (fromIntegral (w .&. 0xff))
bhPut h (fromIntegral (w `shiftR` 8))
get h = do
w2 <- bhGet h
w1 <- bhGet h
return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
instance Binary Word32 where
put_ h w = do
bhPut h (fromIntegral (w .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 8) .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff))
bhPut h (fromIntegral (w `shiftR` 24))
get h = do
w4 <- bhGet h
w3 <- bhGet h
w2 <- bhGet h
w1 <- bhGet h
return $! ((fromIntegral w1 `shiftL` 24) .|.
(fromIntegral w2 `shiftL` 16) .|.
(fromIntegral w3 `shiftL` 8) .|.
(fromIntegral w4))
instance Binary Word64 where
put_ h w = do
bhPut h (fromIntegral (w .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 8) .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 24) .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 32) .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 40) .&. 0xff))
bhPut h (fromIntegral ((w `shiftR` 48) .&. 0xff))
bhPut h (fromIntegral (w `shiftR` 56))
get h = do
w8 <- bhGet h
w7 <- bhGet h
w6 <- bhGet h
w5 <- bhGet h
w4 <- bhGet h
w3 <- bhGet h
w2 <- bhGet h
w1 <- bhGet h
return $! ((fromIntegral w1 `shiftL` 56) .|.
(fromIntegral w2 `shiftL` 48) .|.
(fromIntegral w3 `shiftL` 40) .|.
(fromIntegral w4 `shiftL` 32) .|.
(fromIntegral w5 `shiftL` 24) .|.
(fromIntegral w6 `shiftL` 16) .|.
(fromIntegral w7 `shiftL` 8) .|.
(fromIntegral w8))
-- -----------------------------------------------------------------------------
-- Primitve Int writes
instance Binary Int8 where
put_ h w = put_ h (fromIntegral w :: Word8)
get h = do w <- get h; return $! (fromIntegral (w::Word8))
instance Binary Int16 where
put_ h w = put_ h (fromIntegral w :: Word16)
get h = do w <- get h; return $! (fromIntegral (w::Word16))
instance Binary Int32 where
put_ h w = put_ h (fromIntegral w :: Word32)
get h = do w <- get h; return $! (fromIntegral (w::Word32))
instance Binary Int64 where
put_ h w = put_ h (fromIntegral w :: Word64)
get h = do w <- get h; return $! (fromIntegral (w::Word64))
-- -----------------------------------------------------------------------------
-- Instances for standard types
instance Binary () where
put_ bh () = return ()
get _ = return ()
-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)
instance Binary Bool where
put_ bh b = bhPut bh (fromIntegral (fromEnum b))
get bh = do x <- bhGet bh; return $! (toEnum (fromIntegral x))
-- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
instance Binary Char where
put_ bh c = put_ bh (fromIntegral (ord c) :: Word8)
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word8)))
-- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
instance Binary Int where
#if SIZEOF_HSINT == 4
put_ bh i = put_ bh (fromIntegral i :: Int32)
get bh = do
x <- get bh
return $! (fromIntegral (x :: Int32))
#elif SIZEOF_HSINT == 8
put_ bh i = put_ bh (fromIntegral i :: Int64)
get bh = do
x <- get bh
return $! (fromIntegral (x :: Int64))
#else
#error "unsupported sizeof(HsInt)"
#endif
-- getF bh = getBitsF bh 32
instance Binary a => Binary [a] where
put_ bh list = do put_ bh (length list)
mapM_ (put_ bh) list
get bh = do len <- get bh
let getMany :: Int -> IO [a]
getMany 0 = return []
getMany n = do x <- get bh
xs <- getMany (n-1)
return (x:xs)
getMany len
instance (Binary a, Binary b) => Binary (a,b) where
put_ bh (a,b) = do put_ bh a; put_ bh b
get bh = do a <- get bh
b <- get bh
return (a,b)
instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
get bh = do a <- get bh
b <- get bh
c <- get bh
return (a,b,c)
instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
get bh = do a <- get bh
b <- get bh
c <- get bh
d <- get bh
return (a,b,c,d)
instance Binary a => Binary (Maybe a) where
put_ bh Nothing = bhPut bh 0
put_ bh (Just a) = do bhPut bh 1; put_ bh a
get bh = do h <- bhGet bh
case h of
0 -> return Nothing
_ -> do x <- get bh; return (Just x)
instance (Binary a, Binary b) => Binary (Either a b) where
put_ bh (Left a) = do bhPut bh 0; put_ bh a
put_ bh (Right b) = do bhPut bh 1; put_ bh b
get bh = do h <- bhGet bh
case h of
0 -> do a <- get bh ; return (Left a)
_ -> do b <- get bh ; return (Right b)
instance (Binary a, Binary i, Ix i) => Binary (Array i a) where
put_ bh arr = do put_ bh (Data.Array.bounds arr)
put_ bh (Data.Array.elems arr)
get bh = do bounds <- get bh
elems <- get bh
return $ listArray bounds elems
instance Binary (Bin a) where
put_ bh (BinPtr i) = put_ bh i
get bh = do i <- get bh; return (BinPtr i)
---------------------------------------------------------------
-- Binary Copying
---------------------------------------------------------------
-- |Move from one BinHandle to another, with size. Moves both of
-- their pointers.
copyBytes :: (BinaryHandle h1,BinaryHandle h2)
=> h1 -- ^ src handle
-> h2 -- ^ dest handle
-> Int
-> IO ()
copyBytes from_h to_h sz@(I# _) = {-# SCC "copyBytes" #-} do
src <- getAddrRef from_h sz
dst <- getAddrRef to_h sz
case (src,dst) of
(Just (ByteArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBB" #-}
do binmemmove_BA_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
s_done
d_done
return ()
(Just (SysArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSS" #-}
do binmemmove_PTR_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
s_done
d_done
return ()
(Just (SysArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSB" #-}
do binmemmove_BA_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
s_done
d_done
return ()
(Just (ByteArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBS" #-}
do binmemmove_PTR_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
s_done
d_done
return ()
(Just (ByteArrAddrRef s_buf s_off s_done), Just (FdAddrRef (Fd d_fd) d_done)) -> {-# SCC "copyBytesBF" #-}
do r <- binwrite_BA d_fd s_buf (fromIntegral s_off) (fromIntegral sz)
s_done
d_done
return ()
(Just (FdAddrRef (Fd s_fd) s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesFB" #-}
do seekBin to_h (BinPtr (d_off + sz))
r <- binread_BA d_buf (fromIntegral d_off) s_fd (fromIntegral sz)
s_done
d_done
return ()
_ -> {-# SCC "copyBytes1" #-} copyBytes1 from_h to_h sz
foreign import ccall unsafe "binmemmove" binmemmove_BA_BA
:: MutableByteArray# RealWorld -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO ()
foreign import ccall unsafe "binmemmove" binmemmove_BA_PTR
:: MutableByteArray# RealWorld -> CInt -> Ptr Word8 -> CInt -> CSize -> IO ()
foreign import ccall unsafe "binmemmove" binmemmove_PTR_PTR
:: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CSize -> IO ()
foreign import ccall unsafe "binmemmove" binmemmove_PTR_BA
:: Ptr Word8 -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO ()
foreign import ccall unsafe "binwrite" binwrite_BA
:: CInt -> MutableByteArray# RealWorld -> CInt -> CSize -> IO ()
foreign import ccall unsafe "binread" binread_BA
:: MutableByteArray# RealWorld -> CInt -> CInt -> CSize -> IO ()
-- generic worker function.
copyBytes1 from_h to_h (I# sz)
| sz ==# 0# = return ()
| otherwise = do { v <- bhGet from_h
; bhPut to_h v
; copyBytes1 from_h to_h (I# (sz -# 1#))
}
-- |Just like copy bytes, but takes a function parameter to modify
copyMap :: (BinaryHandle bh1,BinaryHandle bh2,Binary a, Binary b)
=> bh1 -- ^input handle
-> bh2 -- ^output handle
-> Int -- ^number of elements to copy
-> (a -> b) -- ^f is for fun
-> IO ()
copyMap inHandle outHandle (I# sz) f = do
let loop n
| n ==# sz = return ()
| otherwise = do
w <- get inHandle
put outHandle (f w)
loop (n +# 1#)
loop 0#
{-
copyBytesFromPtr :: (BinaryHandle h)
=> Ptr a -- ^ src ptr
-> h -- ^ dest handle
-> Int -- ^ number of bytes
-> IO ()
copyBytesFromPtr ptr h sz@(I# _) = {-# SCC "copyBytesFromPtr" #-} do
copyBytesToPtr :: (BinaryHandle h) =>
=> h -- ^ src ptr
-> Ptr a -- ^ dest handle
-> Int -- ^ number of bytes
-> IO ()
copyBytesToPtr h ptr sz@(I# _) = {-# SCC "copyBytesToPtr" #-} do
copy 0
where
copy i | i == sz = return () -- done
| otherwise = do
v <- peekByteOff ptr i
put h (v :: Word8)
copy (i + 1)
-}
------------------------------------------------------------------------------
-- INTERNAL to this module.
-- get part of a Handle, for copying.
data AddrRef = ByteArrAddrRef
{ ch_byte_arr :: MutableByteArray# RealWorld
, ch_offset :: Int -- offset where the copy (from/to) will start
, ch_done :: IO ()
}
| FdAddrRef
{ ch_fd :: Fd -- the file descriptor
, ch_done :: IO ()
}
| SysArrAddrRef
{ ch_sys_arr :: Ptr Word8
, ch_offset :: Int
, ch_done :: IO ()
}
instance Show AddrRef where
show (ByteArrAddrRef {}) = "ByteArrAddrRef"
show (FdAddrRef fd _) = "FdAddrRef " ++ show fd
show (SysArrAddrRef {}) = "SysArrAddrRef"