{-# OPTIONS -cpp -fglasgow-exts #-} {-# OPTIONS -#include #-} {-# 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"