diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for memorypool + +## 0.1.0.0 -- 2016-08-16 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Lennart Spitzner + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lennart Spitzner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# memorypool + +A very basic memory pool imlemented in haskell. + +The core idea is that the pool allocates large chunks of memory that are +some power-of-two factor (e.g. 256) of some base size (e.g. 10k). +The user of the pool allocates chunks of a power-of-two factor of the base +size (i.e. 10k, 20k, 40k, ..). This scheme avoids fragmentation due to +weirdly-sized holes, but keep in mind that no compaction takes place, so +this kind of fragmentation must be worked around manually if necessary. + +The pool internally allocates memory on the C heap, i.e. outside of any +haskell/GC heap. + +Uses a buddy allocation strategy internally. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/memorypool.cabal b/memorypool.cabal new file mode 100644 --- /dev/null +++ b/memorypool.cabal @@ -0,0 +1,37 @@ +name: memorypool +version: 0.1.0.0 +synopsis: basic memory pool outside of haskell heap/GC +description: See Readme +homepage: https://github.com/lspitzner/memorypool +license: BSD3 +license-file: LICENSE +author: Lennart Spitzner +maintainer: lsp@informatik.uni-kiel.de +copyright: Copyright (C) 2016 Lennart Spitzner +category: System +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/lspitzner/memorypool.git + +library + exposed-modules: System.MemoryPool + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.7 && <4.10, + vector >=0.11.0.0 && <0.12, + containers >=0.5.6.2 && <0.6, + transformers >=0.4.2.0 && <0.6, + unsafe >=0.0 && <0.1 + if impl(ghc<7.10) { + build-depends: + void >=0.7.1 && <0.8 + } diff --git a/src/System/MemoryPool.hs b/src/System/MemoryPool.hs new file mode 100644 --- /dev/null +++ b/src/System/MemoryPool.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MonadComprehensions #-} + +-- | A very basic memory pool imlemented in haskell. +-- +-- The core idea is that the pool allocates large chunks of memory that are +-- some power-of-two factor (e.g. 256) of some base size (e.g. 10k). +-- The user of the pool allocates chunks of a power-of-two factor of the base +-- size (i.e. 10k, 20k, 40k, ..). This scheme avoids fragmentation due to +-- weirdly-sized holes, but keep in mind that no compaction takes place, so +-- this kind of fragmentation must be worked around manually if necessary. +-- +-- The pool internally allocates memory on the C heap, i.e. outside of any +-- haskell/GC heap. +-- +-- Uses a buddy allocation strategy internally. +module System.MemoryPool + ( -- * type + Pool + -- * interface + , create + , allocate + , allocateForeign + -- * low-level and debugging functions + , PoolData + , debugShowPoolFillsData + , debugTracePoolFills + , getPtrFragmentation + , unsafeGetPoolDataSnapshot + ) +where + + + +import Control.Monad ( msum, forM, mzero ) +import Control.Arrow ( second ) +import Data.Maybe ( fromMaybe ) +import Foreign.ForeignPtr +import Foreign.C.Types +import Control.Concurrent.MVar +import Control.Monad.Trans.Maybe ( runMaybeT, MaybeT(..) ) + +import Data.Void ( Void ) + +import Foreign.Ptr ( Ptr ) + +import qualified Data.Vector.Storable.Mutable as VectorSM + +import qualified Data.IntMap as IntMap + +import qualified Foreign.Ptr as Ptr +import qualified Foreign.Concurrent +import qualified Foreign.Marshal.Array +import qualified Foreign.Marshal.Alloc +import qualified System.Unsafe as Unsafe + +import qualified Data.Bits as Bits + +import Control.Applicative ( (<|>) ) + +import Debug.Trace ( trace ) + +import Prelude + + + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap + +-- | Stateful pool object +newtype Pool = Pool (MVar PoolData) + +-- | Internal pool type +data PoolData = PoolData + { _mp_baseSize :: CSize + -- ^ base size. all alocations inside this pool will be rounded up to + -- a multiple of this. + , _mp_blockSizeExp :: CSize + -- ^ the pool internally manages a number of blocks, each containing + -- (2**_mp_blockSizeExp * _mp_baseSize) bytes. + , _mp_blockSize :: CSize + , _mp_poolBlocks :: IntMap.IntMap PoolBlock + -- ^ map to the blocks + , _mp_freeHint :: Int + -- ^ probably an index of some block that _probably_ has some unallocated + -- regions left. no promises; may point to full block or not point to any + -- block at all. + } + +data PoolBlock = PoolBlock (VectorSM.IOVector CSize) (Ptr Void) + +instance Show PoolBlock where + show (PoolBlock v ptr) = Unsafe.performIO $ do + vStr <- fmap show $ [0 .. VectorSM.length v - 1] `forM` VectorSM.read v + return $ "PoolBlock " ++ vStr ++ " " ++ show ptr + +-- blocks use a serialized version of a balanced binary tree. +-- 0 +-- 1 2 +-- 3 4 5 6 +-- +-- at each node, we annotate what the largest completely free subtree, using +-- and Int. 0 means in-use; an empty leaf has a 1; completely empty nodes have +-- n for a node with depth n; a partially filled node has n where n is the +-- annotation on the (largest) non-filled sub-tree. +-- +-- for example, if the usage is +-- _ +-- _ _ +-- _ x _ _ +-- +-- where x denotes the only node currently in use, we annotate this as +-- 2 +-- 1 2 +-- 1 0 1 1 +-- +-- or rather, sequentially: +-- +-- 2,1,2,1,0,1,1. + +-- | Create an empty pool. A pool internally allocates several relatively +-- large blocks via 'malloc' and returns chunks of these when requested via +-- 'allocate'. +-- +-- Note that the rts does not "see" these allocations in any way. I.e. memory +-- allocated in the pool does not count towards heap space in the rts and +-- is not captured by heap profiling. +create + :: CSize -- ^ base size. + -> CSize -- ^ block exponent; each internal block holds + -- (2**block_exp) * base_size. + -- Must be at least 1. + -> IO Pool +create base blockExp = + do + -- finPtr <- $(CInline.mkFunPtrFromName 'poolFin) + let + pool = PoolData + { _mp_baseSize = base + , _mp_blockSizeExp = blockExp + , _mp_blockSize = Bits.shift 1 (fromIntegral blockExp) * base + , _mp_poolBlocks = IntMap.empty + , _mp_freeHint = 0 + -- , _pp_finalizerPtr = finPtr + } + fmap Pool $ newMVar pool + +-- | Allocate memory inside the specified pool. The amount allocated is rounded +-- up to the next power-of-two multiple of the base size. +-- +-- The number of bytes to allocated is limited in both directions: +-- The minimum amount is 1 (0 is an error). +-- The maximum is the number of a bytes in a block as specified by the +-- arguments to @'create'@. +-- +-- No deallocation happens unless the provided deallocation action is executed. +-- (See 'allocateForeign' for a more automatic variant of this function.) +-- +-- The deallocation action must not be called more than once. +allocate + :: Pool -- ^ pool to allocate in + -> CSize -- ^ number of bytes to allocate. + -> IO (IO (), Ptr a) -- ^ the ptr to the memory allocated in the pool, + -- plus a deallaction action. +allocate _ 0 = error "MemoryPool: allocating 0 bytes not supported." +allocate (Pool poolMVar) nBytes = -- traceShow ("allocate", nBytes) $ + do + poolData <- takeMVar poolMVar + let rounded = ((nBytes-1) `div` _mp_baseSize poolData) + 1 + sizeFact = if + | rounded==1 -> 1 + | rounded==2 -> 2 + | rounded<=4 -> 4 + | rounded<=8 -> 8 + | rounded<=16 -> 16 + | rounded<=32 -> 32 + | rounded<=64 -> 64 + | rounded<=128 -> 128 + | rounded<=256 -> 256 + | rounded<=512 -> 512 + | rounded<=1024 -> 1024 + | rounded<=2048 -> 2048 + | rounded<=4096 -> 4096 + | rounded<=8192 -> 8192 + | rounded<=16384 -> 16384 + | rounded<=32768 -> 32768 + | rounded<=65536 -> 65536 -- not the most efficient, and not + | otherwise -> error "MemoryPool: allocation too large!" + (poolData', blockInd, metaInd, fPtr) + :: (PoolData, Int, Int, Ptr Void) + <- allocateFromDepth poolData $ -- traceShow ("sizeFact", sizeFact) $ + sizeFact + -- traceShow poolData' $ + putMVar poolMVar $ poolData' + return (deallocateElem poolMVar blockInd metaInd sizeFact, Ptr.castPtr fPtr) + +-- | Similar to 'allocate', but performs the deallocation automatically as +-- a finalizer on the returned ForeignPtr. This may lead to (arbitrary) delays +-- between dropping of the reference and actual freeing of pool memory, but +-- is much more convenient on usage side. +allocateForeign + :: Pool -- ^ pool to allocate in + -> CSize -- ^ number of bytes to allocate. + -> IO (ForeignPtr a) -- a ForeignPtr that has a finalizer connected to it + -- which performs the deallocation inside the pool. +allocateForeign pool nBytes = do + (destr, ptr) <- allocate pool nBytes + Foreign.Concurrent.newForeignPtr ptr destr + +deallocateElem :: MVar PoolData -> Int -> Int -> CSize -> IO () +deallocateElem poolMVar blockInd metaInd sizeFact = do + poolData <- takeMVar poolMVar + let curBlock = fromMaybe (error "MemoryPool internal error 919238912") + $ IntMap.lookup blockInd (_mp_poolBlocks poolData) + block' <- deallocateElemBlock curBlock metaInd sizeFact + putMVar poolMVar $ poolData + { _mp_poolBlocks = + IntMap.update (const block') blockInd (_mp_poolBlocks poolData) + } +deallocateElemBlock :: PoolBlock -> Int -> CSize -> IO (Maybe PoolBlock) +deallocateElemBlock block@(PoolBlock meta rawPtr) metaInd sizeFact = do + VectorSM.write meta metaInd sizeFact + isEmpty <- go metaInd sizeFact + if isEmpty + then do + -- trace ("freeing memory at " ++ show (Ptr.ptrToIntPtr rawPtr)) $ + Foreign.Marshal.Alloc.free rawPtr + return Nothing + else return $ Just block + where + go :: Int -> CSize -> IO Bool + go 0 _ = return True + go n f = do + let n' = ((n+1) `div` 2) - 1 + do + l <- VectorSM.read meta (2*n'+1) + r <- VectorSM.read meta (2*n'+2) + case (l, r) of + (x, y) | x==f && y==f -> do + VectorSM.write meta n' (2*f) + if n'==0 + then return True + else go n' (2*f) + (x, y) -> do + VectorSM.write meta n' (max x y) + if n'==0 + then return False + else go n' (2*f) +allocateFromDepth + :: PoolData + -> CSize -- factor to baseSize to allocate + -> IO (PoolData, Int, Int, Ptr Void) +allocateFromDepth pool sizeFact = do + runMaybeT opts >>= \case + Nothing -> do + let firstUnusedIndex = + id + $ fst + $ head + $ filter (not . snd) + $ [0..] <&> \i -> (i, IntMap.member i (_mp_poolBlocks pool)) + block <- allocBlock + let pool' = pool + { _mp_poolBlocks = + IntMap.insert firstUnusedIndex block (_mp_poolBlocks pool) + , _mp_freeHint = firstUnusedIndex + } + mR <- runMaybeT $ allocInBlock (firstUnusedIndex, block) + case mR of + Nothing -> error "MemoryPool internal error 88838123" + Just (r1, r2, r3) -> do + return (pool', r1, r2, r3) + Just (r1, r2, r3) -> do + let pool' = pool { _mp_freeHint = r1 } + return (pool', r1, r2, r3) + where + allocBlock :: IO PoolBlock + allocBlock = do + let metaWidth = Bits.shift 1 $ fromIntegral $ _mp_blockSizeExp pool + let metaLength = metaWidth*2 - 1 + let dataLength = _mp_blockSize pool + blockPtr <- -- trace ("allocating " ++ show dataLength ++ " bytes via mallocBytes") $ + Foreign.Marshal.Alloc.mallocBytes $ fromIntegral dataLength + metaPtr <- -- trace ("address is " ++ show (Ptr.ptrToIntPtr blockPtr)) $ + newForeignPtr Foreign.Marshal.Alloc.finalizerFree + =<< Foreign.Marshal.Array.mallocArray (fromIntegral $ metaLength) + let vect = VectorSM.unsafeFromForeignPtr0 metaPtr (fromIntegral $ metaLength) + let go _ 0 = return () + go n f = do + VectorSM.write vect n f + go (2*n+1) (f `div` 2) + go (2*n+2) (f `div` 2) + go 0 metaWidth + return $ PoolBlock vect blockPtr + opts = allocFromHint <|> allocFromAnyBlock + allocFromHint :: MaybeT IO (Int, Int, Ptr Void) + allocFromHint = case IntMap.lookup (_mp_freeHint pool) (_mp_poolBlocks pool) of + Just x -> allocInBlock (_mp_freeHint pool, x) + Nothing -> mzero + allocFromAnyBlock :: MaybeT IO (Int, Int, Ptr Void) + allocFromAnyBlock = do + msum $ fmap allocInBlock $ IntMap.toList $ _mp_poolBlocks pool + allocInBlock + :: (Int, PoolBlock) + -> MaybeT IO (Int, Int, Ptr Void) + allocInBlock (poolInd, PoolBlock meta rawPtr) = MaybeT $ do + -- TODO: why the **** does Ptr.plusPtr not take CUIntPtr as parameter. + r <- go 0 (Bits.shift 1 $ fromIntegral $ _mp_blockSizeExp pool) 0 + case r of + Nothing -> return Nothing + Just (metaInd, offset) -> do + return + $ return + $ ( poolInd + , metaInd + , -- (\x -> traceShow (Ptr.ptrToIntPtr x, Ptr.ptrToIntPtr rawPtr, offset) x) $ + Ptr.plusPtr + rawPtr + (fromIntegral(offset*_mp_baseSize pool)) + ) + where + -- we pass/handle the offsets directly here, because calculating them + -- afterwards is cumbersome (if possible, given the max depth). + -- 0 + -- 1 2 + -- 3 4 5 6 + -- 7 8 9 0¹1¹2¹3¹4 (leafs) + -- 0 1 2 3 4 5 6 7 (offsets) + go :: Int -> CSize -> CSize -> IO (Maybe (Int, CSize)) + go ind depthFact offset = do + x <- VectorSM.read meta ind + case x of + i | i + return Nothing + i | i==depthFact && sizeFact==depthFact -> do + VectorSM.write meta ind 0 + return $ Just (ind, offset) + 1 | depthFact==1 -> do + VectorSM.write meta ind 0 + return $ Just (ind, offset) + _ -> do + -- we are not at depth 1 because of the above clause. + -- consequently we unconditionally need to do the re-calculation of + -- the current node's value below. + leftR <- go (2*ind+1) (depthFact `div` 2) offset + res <- case leftR of + Nothing -> + go (2*ind+2) (depthFact `div` 2) (offset + depthFact `div` 2) + Just{} -> do + return leftR + do + l <- VectorSM.read meta (2*ind+1) + r <- VectorSM.read meta (2*ind+2) + VectorSM.write meta ind (max l r) + return res + + +-- | Return a visual representation of allocation inside the pool. Both +-- distribution of blocks and fragmentation inside each block is displayed. +debugShowPoolFillsData :: PoolData -> String +debugShowPoolFillsData pool + = unlines + $ fmap (\(i, s) -> show i ++ " " ++ s) + $ fmap (second h) + $ IntMap.toList + $ _mp_poolBlocks pool + where + metaWidth = Bits.shift 1 $ fromIntegral $ _mp_blockSizeExp pool + h :: PoolBlock -> String + h (PoolBlock meta _) = Unsafe.performIO $ g meta 0 metaWidth + g meta ind f = do + x <- VectorSM.read meta ind + case x of + 0 | f==1 -> return $ "#" + 1 | f==1 -> return $ " " + 0 -> do + a <- VectorSM.read meta (2*ind+1) + b <- VectorSM.read meta (2*ind+2) + if a==0 || b==0 + then do + l <- g meta (2*ind+1) (f `div` 2) + r <- g meta (2*ind+2) (f `div` 2) + return $ l++r + else return $ '#' : replicate (f-1) '+' + _ -> do + l <- g meta (2*ind+1) (f `div` 2) + r <- g meta (2*ind+2) (f `div` 2) + return $ l++r + +-- | Prints a visual representation of allocation inside the pool to stderr. +-- Both distribution of blocks and fragmentation inside each block is +-- displayed. +debugTracePoolFills :: Pool -> IO () +debugTracePoolFills (Pool poolMVar) = do + poolData <- takeMVar poolMVar + trace ("\n" ++ debugShowPoolFillsData poolData) $ putMVar poolMVar poolData + +-- | if Ptr is not allocated in this pool, returns Nothing. +-- Otherwise returns a rather rough estimate of the usage for the block that +-- the pointer is allocated in. For example if it returns (Just 0.75), at least +-- 25% of the block is free (the other bound should be.. 50% i think. But the +-- error depends in a nontrivial fashion on the value. +-- Use 'unsafeGetPoolDataSnapshot' to obtain the first argument. +getPtrFragmentation :: PoolData -> Ptr a -> Maybe Float +getPtrFragmentation poolData ptr + = msum + $ fmap (\(PoolBlock meta blkptr) -> + [ Unsafe.performIO $ go meta + | ptrV>=blkptr && ptrV<(Ptr.plusPtr blkptr bLen) + ]) + $ IntMap.elems + $ _mp_poolBlocks poolData + where + metaWidth :: Int + metaWidth = Bits.shift 1 $ fromIntegral $ _mp_blockSizeExp poolData + bLen :: Int + bLen = fromIntegral (_mp_blockSize poolData) + ptrV = Ptr.castPtr ptr + go :: VectorSM.IOVector CSize -> IO Float + go meta = do + x <- VectorSM.read meta 0 + y <- VectorSM.read meta 1 + z <- VectorSM.read meta 2 + return $ if + | x==0 -> 1.0 + | True -> 1.0 - fromIntegral (y + z) / fromIntegral metaWidth + +-- | Retrieve a snapshot of the internal data of a pool. This currently exists +-- soly as an argument to 'getPtrFragmentation'. +unsafeGetPoolDataSnapshot :: Pool -> IO PoolData +unsafeGetPoolDataSnapshot (Pool mvar) = readMVar mvar