From e028ac4b464d73f6afee1727d68cedc4e3ed24d5 Mon Sep 17 00:00:00 2001 From: Sam T Date: Thu, 20 Jun 2013 21:25:57 +0400 Subject: ~ merge mmap-fixed package into bittorrent. reason: mmap-fixed is pretty useless out of scope of bittorrent, at least i don't think that it'll be used some time that way. Moreover we can hide some internal stuff and simplify interface and simplify user code. Using mmap-fixed we can provide Storage datatype with all necessary operations needed to keep torrent content in memory of FS. Also that seems pretty annoying to merge this 2 repos into one using git merge(there are not so many stuff anyway), so I just did that manually. :< --- src/System/IO/MMap/Fixed.hs | 203 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100644 src/System/IO/MMap/Fixed.hs (limited to 'src/System') diff --git a/src/System/IO/MMap/Fixed.hs b/src/System/IO/MMap/Fixed.hs new file mode 100644 index 00000000..9d2e354f --- /dev/null +++ b/src/System/IO/MMap/Fixed.hs @@ -0,0 +1,203 @@ +-- TODO pprint +-- TODO see if this IntervalMap is overkill: Interval dataty have 4 constrs +-- TODO clarify lifetime in docs +-- TODO use madvise +-- TODO unmap selected interval +-- TODO tests +-- TODO benchmarks +-- TODO unmap overlapped regions +-- [A] TODO lazy mapping for 32 bit arch; +-- we need tricky algorithm and a lot of perf tests +-- TODO use memmove in write bytes +-- TODO write elem, write byte, read byte +-- | +-- Copyright : (c) Sam T. 2013 +-- License : MIT +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- This library provides mechanism to mmap files to fixed address +-- with fine-grained control. Hovewer, instead of using MAP_FIXED we +-- create our own address space upon virtual address space. If you +-- would like you could call this space as "fixed address space". +-- +-- This solves a few problems: +-- +-- * Page already in use. If you mmap one file at 0..x addresses and +-- want to map second file to x..y addresses using MAP_FIXED you +-- can get in troubles: page might be mapped already. Raw call to +-- mmap will silently unmap x..y addresses and then mmap our second +-- file. So here we have extra unmap we would like to avoid. +-- +-- * Page boundaries. If you mmap one file at x..x+1 you could +-- not map next file to say addresses x+1..x+2. +-- +-- Internally we make ordinary call to mmap to map a file and then +-- using /interval map/ we map fixed address space to virtual +-- address space. It takes TODO time in TODO cases. +-- +-- Basically this library could be used when we need coalesce +-- several files in arbitrary way. We could map at any position as +-- long as offset + size fit in 'Int'. +-- +-- For other details see: +-- +-- > http://hackage.haskell.org/package/mmap +-- > man mmap +-- +module System.IO.MMap.Fixed + ( -- * Intervals + FixedOffset, FileOffset, FixedInterval, FileInterval + , interval, fileInterval + + -- * Construction + , Fixed, Bytes + , System.IO.MMap.Fixed.empty, insertTo + , coalesceFiles + + -- ** Specialized 'insertTo' + , mmapTo, mallocTo + + -- * Query + , upperAddr + + -- * Access + , viewBytes, readBytes, writeBytes + , readElem, writeElem + ) where + +import Data.ByteString.Lazy as Lazy +import Data.ByteString.Lazy.Internal as Lazy +import Data.ByteString.Internal as B +import Data.List as L +import Data.Int +import Data.IntervalMap.Strict as M +import Data.IntervalMap.Interval +import System.IO.MMap +import Foreign + + +type FixedOffset = Int +type FileOffset = Int64 +type Size = Int + + +type FileInterval = (FileOffset, Size) +type FixedInterval = Interval FixedOffset + + +interval :: FixedOffset -> Size -> FixedInterval +interval off s = IntervalCO off (off + fromIntegral (max 0 s)) +{-# INLINE interval #-} + +fileInterval :: FileOffset -> Size -> FileInterval +fileInterval off s = (off, s) +{-# INLINE fileInterval #-} + +intervalSize :: FixedInterval -> Size +intervalSize i = upperBound i - lowerBound i +{-# INLINE intervalSize #-} + + +type Bytes = (ForeignPtr Word8, Size) + +type FixedMap = IntervalMap FixedOffset Bytes + +newtype Fixed = Fixed { imap :: FixedMap } + +instance Show Fixed where + show = show . M.toList . imap + + +mapIM :: (FixedMap -> FixedMap) -> Fixed -> Fixed +mapIM f s = s { imap = f (imap s) } + +empty :: Fixed +empty = Fixed M.empty + +coalesceFiles :: [(FilePath, Int)] -> IO Fixed +coalesceFiles = go 0 System.IO.MMap.Fixed.empty + where + go _ s [] = return s + go offset s ((path, bsize) : xs) = do + s' <- mmapTo path (0, bsize) offset s + go (offset + bsize) s' xs + +upperAddr :: Fixed -> FixedOffset +upperAddr = upperBound . fst . findLast . imap + +insertTo :: FixedInterval -> Bytes -> Fixed -> Fixed +insertTo fi mm = mapIM (M.insert fi mm) +{-# INLINE insertTo #-} + +mmapTo :: FilePath -> FileInterval -> FixedOffset -> Fixed -> IO Fixed +mmapTo path mrange to s = do + (fptr, offset, fsize) <- mmapFileForeignPtr path ReadWriteEx (Just mrange) + + let fixed = interval to fsize + let mmaped = (fptr, offset) + + return $ insertTo fixed mmaped s + +mallocTo :: FixedInterval -> Fixed -> IO Fixed +mallocTo fi s = do + let bsize = intervalSize fi + fptr <- mallocForeignPtrBytes bsize + return (insertTo fi (fptr, 0) s) + +-- | Note: this is unsafe operation. +viewBytes :: FixedInterval -> Fixed -> Lazy.ByteString +viewBytes fi s = fromChunks $ L.map mk $ (imap s `intersecting` fi) + where + mk (i, (fptr, offset)) = + let dropB = max 0 (lowerBound fi - lowerBound i) + dropT = max 0 (upperBound i - upperBound fi) + bsize = intervalSize i - (dropT + dropB) + in fromForeignPtr fptr (offset + dropB) bsize + + +readBytes :: FixedInterval -> Fixed -> IO Lazy.ByteString +readBytes fi s = let c = Lazy.copy (viewBytes fi s) in mkCopy c >> return c +{-# INLINE readBytes #-} + +writeBytes :: FixedInterval -> Lazy.ByteString -> Fixed -> IO () +writeBytes fi bs s = bscpy (viewBytes fi s) bs +{-# INLINE writeBytes #-} + +-- | Note: this operation takes O(log(files count)) time, if possible +-- use readBytes. +readElem :: Storable a => Fixed -> FixedOffset -> IO a +readElem s offset = go undefined + where + go :: Storable a => a -> IO a + go dont_touch = do + let bsize = sizeOf dont_touch + let PS fptr off _ = Lazy.toStrict (viewBytes (interval offset bsize) s) + withForeignPtr fptr $ \ ptr -> peekByteOff ptr off + +writeElem :: Storable a => Fixed -> FixedOffset -> a -> IO () +writeElem s offset x = do + let bsize = sizeOf x + let PS fptr off _ = Lazy.toStrict (viewBytes (interval offset bsize) s) + withForeignPtr fptr $ \ptr -> pokeByteOff ptr off x + + +mkCopy :: Lazy.ByteString -> IO () +mkCopy Empty = return () +mkCopy (Chunk _ x) = mkCopy x + +bscpy :: Lazy.ByteString -> Lazy.ByteString -> IO () +bscpy (PS _ _ 0 `Chunk` dest_rest) src = bscpy dest_rest src +bscpy dest (PS _ _ 0 `Chunk` src_rest) = bscpy dest src_rest +bscpy (PS dest_fptr dest_off dest_size `Chunk` dest_rest) + (PS src_fptr src_off src_size `Chunk` src_rest) + = do let csize = min dest_size src_size + withForeignPtr dest_fptr $ \dest_ptr -> + withForeignPtr src_fptr $ \src_ptr -> + memcpy (dest_ptr `advancePtr` dest_off) + (src_ptr `advancePtr` src_off) + (fromIntegral csize) -- TODO memmove? + bscpy (PS dest_fptr (dest_off + csize) (dest_size - csize) `Chunk` dest_rest) + (PS src_fptr (src_off + csize) (src_size - csize) `Chunk` src_rest) +bscpy _ _ = return () \ No newline at end of file -- cgit v1.2.3