├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── ignite-base └── Ignite │ ├── BlockHeap.hs │ ├── Example.hs │ ├── Layout.hs │ ├── MonotonicHeap.hs │ └── Prim │ ├── Array.hs │ └── Struct.hs ├── ignite-block-heap ├── Example.hs └── Ignite │ └── Heap.hs ├── ignite-heap └── Ignite │ └── Heap.hsig ├── ignite-prelude-indef └── Ignite │ └── Prelude │ ├── ArrayList.hs │ ├── ByteArray.hs │ ├── HashMap.hs │ └── Hashing.hs └── ignite.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | .ghc.environment.* 22 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for ignite 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Alexander Biehl 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexander Biehl nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ignite -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ignite-base/Ignite/BlockHeap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE OverloadedLabels #-} 11 | module Ignite.BlockHeap ( 12 | Heap 13 | , withHeap 14 | , allocStruct 15 | , allocArray 16 | ) where 17 | 18 | import Ignite.Layout 19 | import Ignite.Prim.Array 20 | import Ignite.Prim.Struct 21 | 22 | import Control.Monad.Primitive 23 | import Data.IORef 24 | import Data.Primitive.ByteArray 25 | import Data.Primitive.MutVar 26 | import Data.Primitive.Types 27 | import Data.Proxy 28 | import Foreign.Marshal.Alloc 29 | import Foreign.Ptr 30 | import qualified Foreign.Storable as Storable 31 | import Data.Word 32 | 33 | type BlockLayout = 34 | Struct '[ "nextBlock" := Ptr Word8 ] 35 | 36 | type Allocator = 37 | Struct '[ "nextFree" := Ptr Word8 38 | , "endFree" := Ptr Word8 39 | , "blockSize" := Int 40 | , "firstBlock" := BlockLayout 41 | ] 42 | 43 | allocBlock :: PrimMonad m => Int -> m (Ptr Word8) 44 | allocBlock size = do 45 | unsafeIOToPrim (mallocBytes (size + blockLayoutSize)) 46 | where 47 | blockLayoutSize = structSize (Proxy :: Proxy BlockLayout) 48 | 49 | initAllocator 50 | :: forall a m . PrimMonad m 51 | => Int 52 | -> Ptr a 53 | -> m Allocator 54 | initAllocator blockSize op = do 55 | set blockLayout #nextBlock nullPtr 56 | 57 | set allocator #nextFree firstFreeByte 58 | set allocator #endFree (castPtr op `plusPtr` blockSize) 59 | set allocator #blockSize blockSize 60 | set allocator #firstBlock blockLayout 61 | return allocator 62 | where 63 | blockLayoutSize = structSize (Proxy :: Proxy BlockLayout) 64 | blockLayout = Struct (castPtr op) 65 | 66 | allocatorSize = structSize (Proxy :: Proxy Allocator) 67 | allocator = Struct (castPtr op `plusPtr` blockLayoutSize) :: Allocator 68 | 69 | firstFreeByte = op `plusPtr` (allocatorSize + blockLayoutSize) 70 | 71 | withHeap :: PrimMonad m => Int -> (Heap m root -> m a) -> m a 72 | withHeap blockSize f = do 73 | firstBlock <- allocBlock blockSize 74 | allocator <- initAllocator blockSize firstBlock 75 | f (Heap allocator) 76 | 77 | newtype Heap (m :: * -> *) root = Heap { getHeap :: Allocator } 78 | 79 | allocStruct 80 | :: forall m struct fields root . 81 | ( PrimMonad m 82 | , StructSize struct 83 | , struct ~ Struct fields 84 | ) 85 | => Heap m root 86 | -> Proxy (Struct fields) 87 | -> m (Struct fields) 88 | allocStruct (Heap allocator) _ = do 89 | nextFree <- get allocator #nextFree 90 | endFree <- get allocator #endFree 91 | 92 | op <- if nextFree `plusPtr` size >= endFree 93 | then do blockSize <- get allocator #blockSize 94 | newBlock <- allocBlock (max size blockSize) 95 | let newBlockLayout = Struct (castPtr newBlock) :: BlockLayout 96 | Struct firstBlock <- get allocator #firstBlock :: m BlockLayout 97 | set newBlockLayout #nextBlock (castPtr firstBlock) 98 | set allocator #firstBlock newBlockLayout 99 | let freeSpace = newBlock `plusPtr` blockLayoutSize 100 | set allocator #nextFree (freeSpace `plusPtr` size) 101 | set allocator #endFree (newBlock `plusPtr` blockSize) 102 | return freeSpace 103 | else do set allocator #nextFree (nextFree `plusPtr` size) 104 | return nextFree 105 | 106 | return (Struct (castPtr op)) 107 | where 108 | size = structSize (Proxy :: Proxy struct) 109 | 110 | blockLayoutSize = structSize (Proxy :: Proxy BlockLayout) 111 | 112 | allocArray 113 | :: forall m elem root . 114 | ( PrimMonad m 115 | , Layout elem 116 | ) 117 | => Heap m root 118 | -> Proxy elem 119 | -> Int 120 | -> m (Array elem) 121 | allocArray (Heap allocator) _ n = do 122 | nextFree <- get allocator #nextFree 123 | endFree <- get allocator #endFree 124 | 125 | op <- if nextFree `plusPtr` bytes >= endFree 126 | then do blockSize <- get allocator #blockSize 127 | newBlock <- allocBlock (max bytes blockSize) 128 | let newBlockLayout = Struct (castPtr newBlock) :: BlockLayout 129 | Struct firstBlock <- get allocator #firstBlock 130 | set newBlockLayout #nextBlock (castPtr firstBlock) 131 | set allocator #firstBlock newBlockLayout 132 | let freeSpace = newBlock `plusPtr` blockLayoutSize 133 | set allocator #nextFree (freeSpace `plusPtr` bytes) 134 | set allocator #endFree (newBlock `plusPtr` blockSize) 135 | return freeSpace 136 | else do set allocator #nextFree (nextFree `plusPtr` bytes) 137 | return nextFree 138 | 139 | unsafeIOToPrim (Storable.poke (castPtr op) (n :: Int)) 140 | return (Array (castPtr op)) 141 | where 142 | bytes = size (Proxy :: Proxy Int) + n * size (Proxy :: Proxy elem) 143 | blockLayoutSize = structSize (Proxy :: Proxy BlockLayout) 144 | -------------------------------------------------------------------------------- /ignite-base/Ignite/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE OverloadedLabels #-} 10 | module Ignite.Example where 11 | 12 | import Ignite.Layout 13 | import Ignite.Prim.Array 14 | import Ignite.Prim.Struct 15 | import Ignite.BlockHeap 16 | 17 | import Control.Monad.Primitive 18 | import Data.Proxy 19 | import Data.Foldable 20 | 21 | type ArrayList elem = Struct '[ "size" := Int, "elems" := Array elem ] 22 | 23 | newArrayList 24 | :: forall m elem root . (PrimMonad m, Layout elem) 25 | => Heap m root 26 | -> Int 27 | -> m (ArrayList elem) 28 | newArrayList heap capacity = do 29 | arrayList <- allocStruct heap (Proxy :: Proxy (ArrayList elem)) 30 | array <- allocArray heap (Proxy :: Proxy elem) capacity 31 | set arrayList #size 0 32 | set arrayList #elems array 33 | return arrayList 34 | 35 | arrayListSize 36 | :: forall m elem root . (PrimMonad m) 37 | => ArrayList elem 38 | -> m Int 39 | arrayListSize alist = get alist #size 40 | 41 | arrayListCapacity 42 | :: forall m elem root . (PrimMonad m) 43 | => ArrayList elem 44 | -> m Int 45 | arrayListCapacity alist = do 46 | arr <- get alist #elems 47 | arrayLength arr 48 | 49 | arrayListAppend 50 | :: forall m elem root . (PrimMonad m, Layout elem) 51 | => Heap m root 52 | -> ArrayList elem 53 | -> elem 54 | -> m () 55 | arrayListAppend heap alist elem = do 56 | size <- arrayListSize alist 57 | cap <- arrayListCapacity alist 58 | arr <- get alist #elems 59 | 60 | if size < cap 61 | then do arrayUnsafeWrite arr size elem 62 | set alist #size (size + 1) 63 | else arrayListResize heap alist >> arrayListAppend heap alist elem 64 | 65 | arrayListResize 66 | :: forall m root elem . (PrimMonad m, Layout elem) 67 | => Heap m root 68 | -> ArrayList elem 69 | -> m () 70 | arrayListResize heap alist = do 71 | size <- arrayListSize alist 72 | newArr <- allocArray heap (Proxy :: Proxy elem) (2 * size) 73 | oldArr <- get alist #elems 74 | unsafeArrayCopy oldArr 0 newArr 0 size 75 | set alist #elems newArr 76 | 77 | arrayListIndex 78 | :: forall m elem . (PrimMonad m, Layout elem) 79 | => ArrayList elem 80 | -> Int 81 | -> m elem 82 | arrayListIndex alist i = do 83 | arr <- get alist #elems 84 | arrayUnsafeIndex arr i 85 | 86 | test_monotonic :: IO () 87 | test_monotonic = withHeap 1024 $ \heap -> do 88 | alist <- newArrayList heap 20 :: IO (ArrayList Int) 89 | 90 | for_ [1..25] $ \i -> 91 | arrayListAppend heap alist i 92 | 93 | for_ [0..24] $ \i -> do 94 | x <- arrayListIndex alist i 95 | print x 96 | 97 | test :: ArrayList elem -> IO (Array elem) 98 | test alist = get alist #elems 99 | 100 | test1 :: ArrayList Int -> IO (Array Int) 101 | test1 = test 102 | 103 | test2 :: Layout elem => ArrayList elem -> elem -> IO () 104 | test2 alist elem = do 105 | elems <- get alist #elems 106 | arrayUnsafeWrite elems 0 elem 107 | 108 | test3 :: ArrayList Int -> Int -> IO () 109 | test3 = test2 110 | -------------------------------------------------------------------------------- /ignite-base/Ignite/Layout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module Ignite.Layout where 6 | 7 | import Control.Monad.Primitive 8 | import Data.Proxy 9 | import Data.Word (Word8, Word16, Word32, Word64) 10 | import Foreign.Ptr 11 | import qualified Foreign.Storable as Storable 12 | 13 | -- | A layout defines the in-memory representation for a value. 14 | class Layout a where 15 | 16 | -- | Type of the in-memory representation 17 | type family Rep a 18 | 19 | -- | Determines the size of the representation 20 | size 21 | :: Proxy a 22 | -> Int 23 | 24 | default size 25 | :: Storable.Storable (Rep a) 26 | => Proxy a 27 | -> Int 28 | size _ = Storable.sizeOf (undefined :: Rep a) 29 | {-# INLINE size #-} 30 | 31 | -- | Reads a value from a pointer and an offset 32 | peek 33 | :: PrimMonad m 34 | => Ptr a 35 | -> Int 36 | -> m a 37 | 38 | default peek 39 | :: (PrimMonad m, a ~ Rep a, Storable.Storable (Rep a)) 40 | => Ptr a 41 | -> Int 42 | -> m a 43 | peek op off = unsafeIOToPrim (Storable.peekByteOff op off) 44 | {-# INLINE peek #-} 45 | 46 | -- | Writes a values to pointer at offset. 47 | poke 48 | :: PrimMonad m 49 | => Ptr a 50 | -> Int 51 | -> a 52 | -> m () 53 | 54 | default poke 55 | :: (PrimMonad m, a ~ Rep a, Storable.Storable (Rep a)) 56 | => Ptr a 57 | -> Int 58 | -> a 59 | -> m () 60 | poke op off a = unsafeIOToPrim (Storable.pokeByteOff op off a) 61 | {-# INLINE poke #-} 62 | 63 | instance Layout (Ptr a) where 64 | type Rep (Ptr a) = Ptr a 65 | 66 | instance Layout Int where 67 | type Rep Int = Int 68 | 69 | instance Layout Word where 70 | type Rep Word = Word 71 | 72 | instance Layout Float where 73 | type Rep Float = Float 74 | 75 | instance Layout Bool where 76 | type Rep Bool = Bool 77 | 78 | instance Layout Word8 where 79 | type Rep Word8 = Word8 80 | 81 | instance Layout Word16 where 82 | type Rep Word16 = Word16 83 | 84 | instance Layout Word32 where 85 | type Rep Word32 = Word32 86 | 87 | instance Layout Word64 where 88 | type Rep Word64 = Word64 89 | -------------------------------------------------------------------------------- /ignite-base/Ignite/MonotonicHeap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Ignite.MonotonicHeap ( 4 | Heap 5 | , withHeap 6 | , allocStruct 7 | , allocArray 8 | ) where 9 | 10 | import Ignite.Layout 11 | import Ignite.Prim.Array 12 | import Ignite.Prim.Struct 13 | 14 | import Control.Monad.Primitive 15 | import Data.IORef 16 | import Data.Primitive.ByteArray 17 | import Data.Primitive.MutVar 18 | import Data.Primitive.Types 19 | import Data.Proxy 20 | import Foreign.Ptr 21 | import qualified Foreign.Storable as Storable 22 | 23 | import GHC.Ptr 24 | 25 | -- | A very simple and inefficient heap which allocates a 26 | -- new pinned 'ByteArray' for each allocation. It never 27 | -- releases any memory. 28 | data Heap m root = Heap { 29 | heapBlockSize :: !Int 30 | , heapRoot :: !(MutVar (PrimState m) (Ptr root)) 31 | , heapBlocks :: !(MutVar (PrimState m) [ByteArray]) 32 | } 33 | 34 | -- | Create a new heap and pass it to the given function. 35 | -- Makes sure to keep the 'Heap' alive. 36 | withHeap :: PrimMonad m => (Heap m root -> m a) -> m a 37 | withHeap f = do 38 | heap <- newHeap 1 39 | r <- f heap 40 | touch heap 41 | return r 42 | 43 | newHeap :: PrimMonad m => Int -> m (Heap m root) 44 | newHeap blockSize = do 45 | 46 | rootRef <- newMutVar nullPtr 47 | blockRef <- newMutVar [] 48 | 49 | let heap = 50 | Heap { heapRoot = rootRef 51 | , heapBlockSize = blockSize 52 | , heapBlocks = blockRef 53 | } 54 | 55 | return heap 56 | 57 | -- | Allocate a new 'Struct' on the given Heap. Basically creates 58 | -- a new pinned 'ByteArray' for each allocation. 59 | allocStruct 60 | :: forall m struct fields root . 61 | ( PrimMonad m 62 | , StructSize struct 63 | , struct ~ Struct fields 64 | ) 65 | => Heap m root 66 | -> Proxy (Struct fields) 67 | -> m (Struct fields) 68 | allocStruct heap _ = do 69 | mba <- newPinnedByteArray size 70 | ba <- unsafeFreezeByteArray mba 71 | modifyMutVar' (heapBlocks heap) (\s -> ba : s) 72 | let Addr mem = byteArrayContents ba 73 | return (Struct (Ptr mem)) 74 | where 75 | size = structSize (Proxy :: Proxy struct) 76 | 77 | allocArray 78 | :: forall m elem root . 79 | ( PrimMonad m 80 | , Layout elem 81 | ) 82 | => Heap m root 83 | -> Proxy elem 84 | -> Int 85 | -> m (Array elem) 86 | allocArray heap _ n = do 87 | mba <- newPinnedByteArray bytes 88 | ba <- unsafeFreezeByteArray mba 89 | modifyMutVar' (heapBlocks heap) (\s -> ba : s) 90 | let Addr mem = byteArrayContents ba 91 | op = Ptr mem 92 | unsafeIOToPrim (Storable.poke (castPtr op) (n :: Int)) 93 | return (Array op) 94 | where 95 | bytes = size (Proxy :: Proxy Int) + n * size (Proxy :: Proxy elem) 96 | -------------------------------------------------------------------------------- /ignite-base/Ignite/Prim/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Ignite.Prim.Array where 4 | 5 | import Ignite.Layout 6 | 7 | import Control.Monad.Primitive 8 | import Data.Proxy 9 | import Foreign.Ptr 10 | import Foreign.Marshal.Utils (copyBytes) 11 | import Foreign.Storable (peekElemOff, pokeElemOff) 12 | 13 | -- | A sequence of elements. 14 | -- 15 | -- - 'Array's know their lengths 16 | -- - 'Array's support indexing in constant time 17 | newtype Array elem = Array { getArray :: Ptr (Array elem) } 18 | 19 | instance Layout (Array elem) where 20 | 21 | -- | Keep representation for 'Array' is opaque 22 | type Rep (Array elem) = Array elem 23 | 24 | size _ = size (Proxy :: Proxy (Ptr (Array elem))) 25 | {-# INLINE size #-} 26 | 27 | peek op off = fmap Array (peek (castPtr op) off) 28 | {-# INLINE peek #-} 29 | 30 | poke op off a = poke (castPtr op) off (getArray a) 31 | {-# INLINE poke #-} 32 | 33 | arrayHeaderSize :: Int 34 | arrayHeaderSize = size (Proxy :: Proxy Int) 35 | 36 | arraySize :: Layout elem => Proxy elem -> Int -> Int 37 | arraySize elem n = arrayHeaderSize + n * size elem 38 | 39 | arrayUnsafeFromPtr :: PrimMonad m => Ptr a -> Int -> m (Array elem) 40 | arrayUnsafeFromPtr op n = do 41 | poke (castPtr op) 0 n 42 | return (Array (castPtr op)) 43 | 44 | -- | Returns the length of the 'Array'. This is a constant time operation. 45 | arrayLength :: PrimMonad m => Array elem -> m Int 46 | arrayLength (Array op) = peek (castPtr op) 0 47 | {-# INLINE arrayLength #-} 48 | 49 | -- | 'arrayUnsafeWithElems' allows to access the low-level memory 50 | -- representation of the array. 51 | arrayUnsafeWithElems 52 | :: forall m a elem . (PrimMonad m, Layout elem) 53 | => Array elem 54 | -> (Int -> Ptr (Rep elem) -> m a) 55 | -> m a 56 | arrayUnsafeWithElems a@(Array op) f = do 57 | len <- arrayLength a 58 | f len (op `plusPtr` size (Proxy :: Proxy Int)) 59 | {-# INLINE arrayUnsafeWithElems #-} 60 | 61 | -- | Indexes into the array. No bound checks are performed. This is a 62 | -- constant time operation. 63 | arrayUnsafeIndex 64 | :: forall m elem . (PrimMonad m, Layout elem) 65 | => Array elem 66 | -> Int 67 | -> m elem 68 | arrayUnsafeIndex (Array op) index = 69 | peek (castPtr op) (lenSize + elemSize * index) 70 | where 71 | elemSize = size (Proxy :: Proxy elem) 72 | lenSize = size (Proxy :: Proxy Int) 73 | {-# INLINE arrayUnsafeIndex #-} 74 | 75 | -- | Write an element at a specific index. No bounds checking is performed. 76 | arrayUnsafeWrite 77 | :: forall m elem . (PrimMonad m, Layout elem) 78 | => Array elem 79 | -> Int 80 | -> elem 81 | -> m () 82 | arrayUnsafeWrite (Array op) index elem = 83 | poke (castPtr op) (lenSize + elemSize * index) elem 84 | where 85 | elemSize = size (Proxy :: Proxy elem) 86 | lenSize = size (Proxy :: Proxy Int) 87 | {-# INLINE arrayUnsafeWrite #-} 88 | 89 | -- | Copies one array into the other. 90 | unsafeArrayCopy 91 | :: forall m elem . (PrimMonad m, Layout elem) 92 | => Array elem 93 | -> Int 94 | -> Array elem 95 | -> Int 96 | -> Int 97 | -> m () 98 | unsafeArrayCopy (Array src) srcOff (Array dest) destOff len = 99 | unsafeIOToPrim (copyBytes 100 | (dest `plusPtr` (lenSize + destOff * elemSize)) 101 | (src `plusPtr` (lenSize + srcOff * elemSize)) 102 | (len * elemSize)) 103 | where 104 | elemSize = size (Proxy :: Proxy elem) 105 | lenSize = size (Proxy :: Proxy Int) 106 | {-# INLINE unsafeArrayCopy #-} 107 | 108 | arrayForeach 109 | :: forall m elem . (PrimMonad m, Layout elem) 110 | => Array elem 111 | -> (Int -> elem -> m elem) 112 | -> m () 113 | arrayForeach array f = do 114 | len <- arrayLength array 115 | go 0 len 116 | where 117 | go i n 118 | | i < n = do elem <- arrayUnsafeIndex array i 119 | elem' <- f i elem 120 | arrayUnsafeWrite array i elem' 121 | go (i + 1) n 122 | | otherwise = return () 123 | {-# INLINE arrayForeach #-} 124 | -------------------------------------------------------------------------------- /ignite-base/Ignite/Prim/Struct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | module Ignite.Prim.Struct where 10 | 11 | import Ignite.Layout 12 | 13 | import Control.Monad.Primitive 14 | import Data.Kind 15 | import Data.Proxy 16 | import Foreign.Ptr 17 | 18 | import GHC.TypeLits 19 | import GHC.OverloadedLabels 20 | 21 | newtype Struct (fields :: [Type]) = Struct { getStruct :: Ptr (Struct fields) } 22 | 23 | nullStruct :: Struct fields 24 | nullStruct = Struct nullPtr 25 | 26 | isNullStruct :: Struct fields -> Bool 27 | isNullStruct s = s `equalsIdentity` nullStruct 28 | 29 | equalsIdentity :: Struct fields -> Struct fields -> Bool 30 | equalsIdentity (Struct op1) (Struct op2) = op1 == op2 31 | 32 | instance Layout (Struct fields) where 33 | 34 | type Rep (Struct fields) = Struct fields 35 | 36 | size _ = size (Proxy :: Proxy (Ptr (Struct fields))) 37 | {-# INLINE size #-} 38 | 39 | peek op off = fmap Struct (peek (castPtr op) off) 40 | {-# INLINE peek #-} 41 | 42 | poke op off a = poke (castPtr op) off (getStruct a) 43 | {-# INLINE poke #-} 44 | 45 | class StructSize a where 46 | structSize :: Proxy a -> Int 47 | 48 | instance StructSize (Struct '[]) where 49 | structSize _ = 0 50 | 51 | instance (Layout field, StructSize (Struct fields)) 52 | => StructSize (Struct (field ': fields)) where 53 | structSize _ = 54 | size (Proxy :: Proxy field) + 55 | structSize (Proxy :: Proxy (Struct fields)) 56 | 57 | -- | Fields of structures are represented through '(:=)'. 58 | data (label :: Symbol) := (rep :: Type) = Field 59 | 60 | instance Layout rep => Layout (label := rep) where 61 | 62 | type Rep (label := rep) = Rep rep 63 | 64 | size _ = size (Proxy :: Proxy rep) 65 | 66 | peek op off = peek (castPtr op) off 67 | 68 | poke op off a = poke (castPtr op) off a 69 | 70 | -- | Calculates the byte offset of a field in a structure. 71 | class FieldOffset (field :: Symbol) struct where 72 | fieldOffset :: Proxy field -> Proxy struct -> Int 73 | 74 | instance {-# OVERLAPPING #-} ( Layout value ) 75 | => FieldOffset field (Struct (field := value ': fields)) where 76 | fieldOffset _ _ = 0 77 | {-# INLINE fieldOffset #-} 78 | 79 | instance ( Layout value 80 | , FieldOffset field (Struct fields)) 81 | => FieldOffset field (Struct (label := value ': fields)) where 82 | fieldOffset wanted _ = 83 | size (Proxy :: Proxy value) + 84 | fieldOffset wanted (Proxy :: Proxy (Struct fields)) 85 | {-# INLINE fieldOffset #-} 86 | 87 | -- | Calculates the type of a specific field 88 | type family FieldType (field :: Symbol) (fields :: Type) :: Type where 89 | FieldType field (Struct (field := value ': fields)) = value 90 | FieldType field (Struct (label := value ': fields)) = FieldType field (Struct fields) 91 | 92 | instance (label ~ field) => IsLabel (field :: Symbol) (Selector label) where 93 | fromLabel = Selector 94 | 95 | data Selector (field :: Symbol) = Selector 96 | 97 | -- | Reads the value of a field. 98 | get 99 | :: forall field fields fieldType struct m . 100 | ( PrimMonad m 101 | , struct ~ Struct fields 102 | , FieldOffset field struct 103 | , fieldType ~ FieldType field struct 104 | , Layout fieldType 105 | ) 106 | => Struct fields 107 | -> Selector field 108 | -> m (FieldType field struct) -- ^ the read value 109 | get (Struct op) _ = peek (castPtr op) offset 110 | where 111 | offset = fieldOffset (Proxy :: Proxy field) (Proxy :: Proxy struct) 112 | 113 | set 114 | :: forall field fields fieldType m . 115 | ( PrimMonad m 116 | , FieldOffset field (Struct fields) 117 | , Layout (FieldType field (Struct fields)) 118 | , fieldType ~ FieldType field (Struct fields) 119 | ) 120 | => Struct fields -- ^ struct to which to write 121 | -> Selector field -- ^ field selector 122 | -> fieldType -- ^ the value to be written 123 | -> m () 124 | set (Struct op) _ a = poke (castPtr op) offset a 125 | where 126 | offset = fieldOffset (Proxy :: Proxy field) (Proxy :: Proxy (Struct fields)) 127 | 128 | unsafeFromPtr :: Ptr a -> Struct fields 129 | unsafeFromPtr op = Struct (castPtr op) 130 | -------------------------------------------------------------------------------- /ignite-block-heap/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE OverloadedLabels #-} 10 | module Main where 11 | 12 | import Ignite.Layout 13 | import Ignite.Prim.Array 14 | import Ignite.Prim.Struct 15 | import Ignite.BlockHeap 16 | import Ignite.BlockHeap.Prelude.ArrayList 17 | import Ignite.BlockHeap.Prelude.HashMap 18 | 19 | import Control.Monad.Primitive 20 | import Data.Proxy 21 | import Data.Foldable 22 | 23 | 24 | test_monotonic :: IO () 25 | test_monotonic = withHeap 2048 $ \heap -> do 26 | 27 | hm <- newHashMap heap 16 0.75 :: IO (HashMap Int Int) 28 | alist <- newArrayList heap 20 :: IO (ArrayList Int) 29 | 30 | for_ [1..25] $ \i -> do 31 | insert heap hm i i 32 | arrayListAppend heap alist i 33 | 34 | for_ [0..24] $ \i -> do 35 | y <- Ignite.BlockHeap.Prelude.HashMap.lookup hm i 36 | print y 37 | x <- arrayListIndex alist i 38 | print x 39 | 40 | test :: ArrayList elem -> IO (Array elem) 41 | test alist = get alist #elems 42 | 43 | test1 :: ArrayList Int -> IO (Array Int) 44 | test1 = test 45 | 46 | test2 :: Layout elem => ArrayList elem -> elem -> IO () 47 | test2 alist elem = do 48 | elems <- get alist #elems 49 | arrayUnsafeWrite elems 0 elem 50 | 51 | test3 :: ArrayList Int -> Int -> IO () 52 | test3 = test2 53 | 54 | main :: IO () 55 | main = test_monotonic 56 | -------------------------------------------------------------------------------- /ignite-block-heap/Ignite/Heap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE OverloadedLabels #-} 11 | module Ignite.Heap ( 12 | Heap 13 | , withHeap 14 | , allocStruct 15 | , allocArray 16 | ) where 17 | 18 | import Ignite.Layout 19 | import Ignite.Prim.Array 20 | import Ignite.Prim.Struct 21 | 22 | import Control.Exception 23 | import Control.Monad.Primitive 24 | import Data.IORef 25 | import Data.Primitive.ByteArray 26 | import Data.Primitive.MutVar 27 | import Data.Primitive.Types 28 | import Data.Proxy 29 | import Foreign.Marshal.Alloc 30 | import Foreign.Ptr 31 | import qualified Foreign.Storable as Storable 32 | import Data.Word 33 | 34 | -- | Memory is allocated from 'Block's. 'Block's are chained through 35 | -- the 'nextBlock' field. This is a newtype since GHC doesn't like 36 | -- infinite type synonyms. 37 | newtype Block = Block { getBlock :: Struct '[ "nextBlock" := Block ] } 38 | 39 | instance Layout Block where 40 | type Rep Block = Ptr (Struct '[ "nextBlock" := Block ]) 41 | size _ = size (Proxy :: Proxy (Rep Block)) 42 | peek op off = fmap Block (peek (castPtr op) off) 43 | poke op off a = poke (castPtr op) off (getBlock a) 44 | 45 | nullBlock :: Block 46 | nullBlock = Block (unsafeFromPtr nullPtr) 47 | 48 | blockHeaderSize :: Int 49 | blockHeaderSize = 50 | -- FIXME: find a way to get to the type of a Block 51 | structSize (Proxy :: Proxy (Struct '[ "nextBlock" := Block ])) 52 | 53 | -- | We want to allocate new memory through malloc or the like 54 | -- so we need a way to cast a raw pointer to something which looks 55 | -- like a block. Hopefully op is big enough to hold the nextBlock 56 | -- pointer! 57 | unsafeBlockFromPointer 58 | :: PrimMonad m 59 | => Ptr a 60 | -> Block 61 | -> m Block 62 | unsafeBlockFromPointer op nextBlock = do 63 | set block #nextBlock nextBlock 64 | return (Block block) 65 | where 66 | block = unsafeFromPtr op 67 | 68 | blockRawMemory :: Block -> Ptr Word8 69 | blockRawMemory (Block (Struct block)) = 70 | block `plusPtr` blockHeaderSize 71 | 72 | type Allocator = 73 | Struct '[ "hp" := Ptr Word8 74 | , "hpLim" := Ptr Word8 75 | , "blockSize" := Int 76 | , "blocks" := Block 77 | ] 78 | 79 | data OutOfMemoryException = OutOfMemoryException 80 | deriving (Eq, Show) 81 | 82 | instance Exception OutOfMemoryException 83 | 84 | allocatorSize :: Int 85 | allocatorSize = structSize (Proxy :: Proxy Allocator) 86 | 87 | allocRawMemory :: PrimMonad m => Int -> m (Ptr Word8) 88 | allocRawMemory size = unsafeIOToPrim $ do 89 | op <- mallocBytes size 90 | if op == nullPtr 91 | then throwIO OutOfMemoryException 92 | else return op 93 | 94 | -- | Take a bootstrap 'Block' and put the allocator in the first bytes the 95 | -- blocks memory. 96 | bootstrapAllocator 97 | :: PrimMonad m 98 | => Int 99 | -> Block 100 | -> m Allocator 101 | bootstrapAllocator blockSize block = do 102 | set allocator #hp (blockRawMemory block `plusPtr` allocatorSize) 103 | set allocator #hpLim (blockRawMemory block `plusPtr` (blockSize - blockHeaderSize)) 104 | set allocator #blockSize blockSize 105 | set allocator #blocks block 106 | return allocator 107 | where 108 | allocator = unsafeFromPtr (blockRawMemory block) 109 | 110 | -- | The current block is full, allocate a new one and chain the old 111 | -- ones to it. We explicitly pass HpAlloc here as we want to be able 112 | -- to allocate more than blocksize if necessary. 113 | allocateNewBlock :: PrimMonad m => Allocator -> Int -> m (Ptr Word8) 114 | allocateNewBlock allocator hpAlloc = do 115 | blockMem <- allocRawMemory hpAlloc 116 | blocks <- get allocator #blocks 117 | newBlock <- unsafeBlockFromPointer blockMem blocks 118 | 119 | let hp = blockRawMemory newBlock 120 | set allocator #hp hp 121 | set allocator #hpLim (hp `plusPtr` (hpAlloc - blockHeaderSize)) 122 | set allocator #blocks newBlock 123 | return hp 124 | 125 | newtype Heap (m :: * -> *) root = Heap { getHeap :: Allocator } 126 | 127 | alloc :: PrimMonad m => Allocator -> Int -> m (Ptr Word8) 128 | alloc allocator hpAlloc = do 129 | hp <- get allocator #hp 130 | hpLim <- get allocator #hpLim 131 | let hp' = hp `plusPtr` hpAlloc 132 | if hp' >= hpLim 133 | then do blockSize <- get allocator #blockSize 134 | allocateNewBlock 135 | allocator (if hpAlloc > blockSize - blockHeaderSize 136 | then hpAlloc + blockHeaderSize else blockSize) 137 | else do set allocator #hp hp' 138 | return hp 139 | 140 | allocStruct 141 | :: forall m struct fields root . 142 | ( PrimMonad m 143 | , struct ~ Struct fields 144 | , StructSize struct 145 | ) 146 | => Heap m root 147 | -> Proxy (Struct fields) 148 | -> m (Struct fields) 149 | allocStruct (Heap allocator) struct = do 150 | hp <- alloc allocator hpAlloc 151 | return (unsafeFromPtr hp) 152 | where 153 | hpAlloc :: Int 154 | hpAlloc = structSize struct 155 | 156 | allocArray 157 | :: forall m elem root . 158 | ( PrimMonad m 159 | , Layout elem 160 | ) 161 | => Heap m root 162 | -> Proxy elem 163 | -> Int 164 | -> m (Array elem) 165 | allocArray (Heap allocator) elem n = do 166 | hp <- alloc allocator hpAlloc 167 | arrayUnsafeFromPtr hp n 168 | where 169 | hpAlloc = arraySize elem n 170 | 171 | withHeap :: PrimMonad m => Int -> (Heap m root -> m a) -> m a 172 | withHeap blockSize f = do 173 | -- the first block needs some space for the allocator 174 | op <- allocRawMemory (max blockSize (blockHeaderSize + allocatorSize)) 175 | block <- unsafeBlockFromPointer op nullBlock 176 | allocator <- bootstrapAllocator (max blockSize blockHeaderSize) block 177 | r <- f (Heap allocator) 178 | -- FIXME: deallocate the heap 179 | -- FIXME: exception safety 180 | return r 181 | -------------------------------------------------------------------------------- /ignite-heap/Ignite/Heap.hsig: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | signature Ignite.Heap where 5 | 6 | import Ignite.Layout 7 | import Ignite.Prim.Array 8 | import Ignite.Prim.Struct 9 | 10 | import Control.Monad.Primitive 11 | import Data.Proxy 12 | 13 | data Heap (m :: * -> *) root 14 | 15 | allocStruct 16 | :: ( PrimMonad m 17 | , struct ~ Struct fields 18 | , StructSize struct 19 | ) 20 | => Heap m root 21 | -> Proxy (Struct fields) 22 | -> m (Struct fields) 23 | 24 | allocArray 25 | :: (PrimMonad m, Layout elem) 26 | => Heap m root 27 | -> Proxy elem 28 | -> Int 29 | -> m (Array elem) 30 | -------------------------------------------------------------------------------- /ignite-prelude-indef/Ignite/Prelude/ArrayList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE OverloadedLabels #-} 7 | module Ignite.Prelude.ArrayList ( 8 | ArrayList 9 | , newArrayList 10 | , arrayListSize 11 | , arrayListAppend 12 | , arrayListIndex 13 | ) where 14 | 15 | import Ignite.Heap 16 | import Ignite.Layout 17 | import Ignite.Prim.Array 18 | import Ignite.Prim.Struct 19 | 20 | import Control.Monad.Primitive 21 | import Data.Proxy 22 | 23 | type ArrayList elem = Struct '[ "size" := Int, "elems" := Array elem ] 24 | 25 | newArrayList 26 | :: forall m elem root . (PrimMonad m, Layout elem) 27 | => Heap m root 28 | -> Int 29 | -> m (ArrayList elem) 30 | newArrayList heap capacity = do 31 | arrayList <- allocStruct heap (Proxy :: Proxy (ArrayList elem)) 32 | array <- allocArray heap (Proxy :: Proxy elem) capacity 33 | set arrayList #size 0 34 | set arrayList #elems array 35 | return arrayList 36 | 37 | arrayListSize 38 | :: forall m elem root . (PrimMonad m) 39 | => ArrayList elem 40 | -> m Int 41 | arrayListSize alist = get alist #size 42 | 43 | arrayListCapacity 44 | :: forall m elem root . (PrimMonad m) 45 | => ArrayList elem 46 | -> m Int 47 | arrayListCapacity alist = do 48 | arr <- get alist #elems 49 | arrayLength arr 50 | 51 | arrayListAppend 52 | :: forall m elem root . (PrimMonad m, Layout elem) 53 | => Heap m root 54 | -> ArrayList elem 55 | -> elem 56 | -> m () 57 | arrayListAppend heap alist elem = do 58 | size <- arrayListSize alist 59 | cap <- arrayListCapacity alist 60 | arr <- get alist #elems 61 | 62 | if size < cap 63 | then do arrayUnsafeWrite arr size elem 64 | set alist #size (size + 1) 65 | else arrayListResize heap alist >> arrayListAppend heap alist elem 66 | 67 | arrayListResize 68 | :: forall m root elem . (PrimMonad m, Layout elem) 69 | => Heap m root 70 | -> ArrayList elem 71 | -> m () 72 | arrayListResize heap alist = do 73 | size <- arrayListSize alist 74 | newArr <- allocArray heap (Proxy :: Proxy elem) (2 * size) 75 | oldArr <- get alist #elems 76 | unsafeArrayCopy oldArr 0 newArr 0 size 77 | set alist #elems newArr 78 | 79 | arrayListIndex 80 | :: forall m elem . (PrimMonad m, Layout elem) 81 | => ArrayList elem 82 | -> Int 83 | -> m elem 84 | arrayListIndex alist i = do 85 | arr <- get alist #elems 86 | arrayUnsafeIndex arr i 87 | -------------------------------------------------------------------------------- /ignite-prelude-indef/Ignite/Prelude/ByteArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Ignite.Prelude.ByteArray where 3 | 4 | import Ignite.Prim.Array 5 | 6 | import Control.Monad.Primitive 7 | import Data.Word (Word8) 8 | import Foreign.Marshal.Utils 9 | import Foreign.Ptr 10 | 11 | type ByteArray = Array Word8 12 | 13 | fill :: PrimMonad m => ByteArray -> Ptr Word8 -> Int -> m () 14 | fill array op n = 15 | arrayUnsafeWithElems array (\m elems -> unsafeIOToPrim (f m elems)) 16 | where 17 | f :: Int -> Ptr Word8 -> IO () 18 | f m elems = copyBytes elems op (min m n) 19 | -------------------------------------------------------------------------------- /ignite-prelude-indef/Ignite/Prelude/HashMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE OverloadedLabels #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | module Ignite.Prelude.HashMap where 10 | 11 | import Ignite.Heap 12 | import Ignite.Layout 13 | import Ignite.Prim.Array 14 | import Ignite.Prim.Struct 15 | 16 | import Ignite.Prelude.Hashing 17 | 18 | import Control.Monad.Primitive 19 | import Data.Bits 20 | import Data.Proxy 21 | import Foreign.Ptr 22 | import Data.Word 23 | 24 | type LoadFactor = Float 25 | 26 | type Entry k v = 27 | Struct '[ "hash" := Hash 28 | , "key" := k 29 | , "value" := v 30 | , "next" := Ptr Word8 -- hack 31 | ] 32 | 33 | type HashMap k v = 34 | Struct '[ "table" := Array (Entry k v) 35 | , "size" := Int 36 | , "threshold" := Int 37 | , "loadFactor" := Float 38 | , "modCount" := Int 39 | ] 40 | 41 | defaultInitialCapacity :: Int 42 | defaultInitialCapacity = 16 43 | 44 | newHashMap 45 | :: forall m root k v . (PrimMonad m, Layout k, Layout v) 46 | => Heap m root 47 | -> Int 48 | -> LoadFactor 49 | -> m (HashMap k v) 50 | newHashMap heap _initialCapacity loadFactor = do 51 | this <- allocStruct heap (Proxy :: Proxy (HashMap k v)) 52 | entries <- allocArray heap (Proxy :: Proxy (Entry k v)) capacity 53 | 54 | set this #table entries 55 | set this #size 0 56 | set this #threshold (round (fromIntegral capacity * loadFactor)) 57 | set this #loadFactor loadFactor 58 | set this #modCount 0 59 | 60 | return this 61 | where 62 | capacity = defaultInitialCapacity 63 | 64 | class Equals a where 65 | isEqual :: PrimMonad m => a -> a -> m Bool 66 | 67 | instance Equals Int where 68 | isEqual = equalsEq 69 | 70 | equalsEq :: (Eq a, PrimMonad m) => a -> a -> m Bool 71 | equalsEq a b = return (a == b) 72 | 73 | insert 74 | :: forall m root k v . 75 | ( PrimMonad m 76 | , Layout k 77 | , Layout v 78 | , Equals k 79 | , HashCode k 80 | ) 81 | => Heap m root 82 | -> HashMap k v 83 | -> k 84 | -> v 85 | -> m () 86 | insert heap this k v = do 87 | hash <- hashWithSeed 0 k 88 | entries <- get this #table 89 | capacity <- arrayLength entries 90 | let 91 | i = indexOf hash capacity 92 | 93 | loop e 94 | | isNullStruct e = addEntry heap this hash k v i 95 | | otherwise = do 96 | entryHash <- get e #hash 97 | entryKey <- get e #key 98 | 99 | if entryHash == hash 100 | then do eq <- isEqual entryKey k 101 | if eq 102 | then do oldVal <- get e #value 103 | set e #value v 104 | else addEntry heap this hash k v i 105 | else do next <- get e #next 106 | loop (unsafeFromPtr next) 107 | 108 | entry <- arrayUnsafeIndex entries i 109 | loop entry 110 | return () 111 | 112 | addEntry 113 | :: forall m root k v . (PrimMonad m, Layout k, Layout v, Equals k, HashCode k) 114 | => Heap m root 115 | -> HashMap k v 116 | -> Hash 117 | -> k 118 | -> v 119 | -> Int 120 | -> m () 121 | addEntry heap this hash key value bucketIndex = do 122 | entries <- get this #table 123 | Struct entry <- arrayUnsafeIndex entries bucketIndex 124 | newEntry <- allocStruct heap (Proxy :: Proxy (Entry k v)) 125 | set newEntry #hash hash 126 | set newEntry #key key 127 | set newEntry #value value 128 | set newEntry #next (castPtr entry) 129 | arrayUnsafeWrite entries bucketIndex newEntry 130 | 131 | size <- get this #size 132 | let size' = size + 1 133 | set this #size size' 134 | 135 | threshold <- get this #threshold 136 | if (size' >= threshold) 137 | then do cap <- arrayLength entries 138 | resize heap this (2 * cap) 139 | else return () 140 | 141 | resize 142 | :: forall m root k v . (PrimMonad m, Layout k, Layout v, HashCode k, Equals k) 143 | => Heap m root 144 | -> HashMap k v 145 | -> Int 146 | -> m () 147 | resize heap this newCapacity = do 148 | oldTable <- get this #table 149 | oldCapacity <- arrayLength oldTable 150 | newTable <- allocArray heap (Proxy :: Proxy (Entry k v)) newCapacity 151 | 152 | let 153 | transfer i 154 | | i < oldCapacity = do 155 | entry <- arrayUnsafeIndex oldTable i 156 | if not (isNullStruct entry) 157 | then do arrayUnsafeWrite oldTable i nullStruct 158 | let 159 | transfer1 e 160 | | isNullStruct e = return () 161 | | otherwise = do 162 | hash <- get e #hash 163 | next <- get e #next 164 | let j = indexOf hash newCapacity 165 | Struct next' <- arrayUnsafeIndex newTable j 166 | set e #next (castPtr next') 167 | arrayUnsafeWrite newTable j e 168 | transfer1 (unsafeFromPtr next) 169 | 170 | transfer1 entry 171 | else return () 172 | transfer (i + 1) 173 | | otherwise = return () 174 | 175 | transfer 0 176 | 177 | loadFactor <- get this #loadFactor 178 | set this #table newTable 179 | set this #threshold (round (fromIntegral newCapacity * loadFactor)) 180 | 181 | lookup 182 | :: forall m root k v . 183 | ( PrimMonad m 184 | , Layout k 185 | , Layout v 186 | , HashCode k 187 | , Equals k 188 | ) 189 | => HashMap k v 190 | -> k 191 | -> m (Maybe v) 192 | lookup this k = do 193 | hash <- hashWithSeed 0 k 194 | entries <- get this #table 195 | capacity <- arrayLength entries 196 | entry <- arrayUnsafeIndex entries (indexOf hash capacity) 197 | 198 | let 199 | loop :: Entry k v -> m (Maybe v) 200 | loop !e 201 | | isNullStruct e = return Nothing 202 | | otherwise = do 203 | entryHash <- get e #hash 204 | entryKey <- get e #key 205 | 206 | if entryHash == hash 207 | then do key <- get e #key 208 | eq <- isEqual k key 209 | if eq 210 | then do val <- get e #value 211 | return (Just val) 212 | else do next <- get e #next 213 | loop (unsafeFromPtr next) 214 | else do next <- get e #next 215 | loop (unsafeFromPtr next) 216 | loop entry 217 | 218 | -- | Index for 'Hash' in the table 219 | indexOf :: Hash -> Int -> Int 220 | indexOf hash length = hash .&. (length - 1) 221 | -------------------------------------------------------------------------------- /ignite-prelude-indef/Ignite/Prelude/Hashing.hs: -------------------------------------------------------------------------------- 1 | module Ignite.Prelude.Hashing where 2 | 3 | import Control.Monad.Primitive 4 | import Data.Hashable 5 | 6 | type Hash = Int 7 | 8 | type Seed = Int 9 | 10 | class HashCode a where 11 | hashWithSeed :: PrimMonad m => Seed -> a -> m Hash 12 | 13 | instance HashCode Int where 14 | hashWithSeed = hashableHashcode 15 | 16 | hashableHashcode :: (Hashable a, PrimMonad m) => Seed -> a -> m Hash 17 | hashableHashcode seed a = return (hashWithSalt seed a) 18 | -------------------------------------------------------------------------------- /ignite.cabal: -------------------------------------------------------------------------------- 1 | -- Initial ignite.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: ignite 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Alexander Biehl 11 | maintainer: abiehl@novomind.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md, README.md 16 | cabal-version: >=2.0 17 | 18 | library ignite-heap 19 | signatures: Ignite.Heap 20 | build-depends: base >=4.10 && <4.11, 21 | primitive, 22 | ignite-base 23 | hs-source-dirs: ignite-heap 24 | default-language: Haskell2010 25 | 26 | library ignite-block-heap 27 | exposed-modules: Ignite.Heap 28 | reexported-modules: Ignite.Heap as Ignite.BlockHeap 29 | build-depends: base, primitive, ignite-base 30 | default-language: Haskell2010 31 | hs-source-dirs: ignite-block-heap 32 | 33 | library ignite-prelude-indef 34 | exposed-modules: Ignite.Prelude.ArrayList 35 | Ignite.Prelude.ByteArray 36 | Ignite.Prelude.Hashing 37 | Ignite.Prelude.HashMap 38 | 39 | -- other-modules: 40 | -- other-extensions: 41 | build-depends: base >=4.10 && <4.11, 42 | primitive, 43 | ignite-base, ignite-heap, 44 | hashable 45 | hs-source-dirs: ignite-prelude-indef 46 | default-language: Haskell2010 47 | 48 | library ignite-base 49 | exposed-modules: Ignite.Layout 50 | Ignite.Prim.Array 51 | Ignite.Prim.Struct 52 | 53 | -- other-modules: 54 | -- other-extensions: 55 | build-depends: base >=4.10 && <4.11, 56 | primitive 57 | hs-source-dirs: ignite-base 58 | default-language: Haskell2010 59 | 60 | library 61 | reexported-modules: Ignite.Layout, 62 | Ignite.Prim.Array, 63 | Ignite.Prim.Struct, 64 | 65 | Ignite.BlockHeap, 66 | Ignite.BlockHeap.Prelude.ArrayList, 67 | Ignite.BlockHeap.Prelude.ByteArray, 68 | Ignite.BlockHeap.Prelude.HashMap 69 | 70 | mixins: ignite-prelude-indef (Ignite.Prelude.ArrayList as Ignite.BlockHeap.Prelude.ArrayList) 71 | requires (Ignite.Heap as Ignite.BlockHeap), 72 | ignite-prelude-indef (Ignite.Prelude.ByteArray as Ignite.BlockHeap.Prelude.ByteArray) 73 | requires (Ignite.Heap as Ignite.BlockHeap), 74 | ignite-prelude-indef (Ignite.Prelude.HashMap as Ignite.BlockHeap.Prelude.HashMap) 75 | requires (Ignite.Heap as Ignite.BlockHeap) 76 | 77 | -- other-modules: 78 | -- other-extensions: 79 | build-depends: base >=4.10 && <4.11, 80 | primitive, 81 | ignite-base, 82 | ignite-prelude-indef, 83 | ignite-block-heap 84 | default-language: Haskell2010 85 | 86 | 87 | executable ignite-block-heap-example 88 | main-is: Example.hs 89 | build-depends: base, primitive, ignite 90 | hs-source-dirs: ignite-block-heap 91 | default-language: Haskell2010 92 | --------------------------------------------------------------------------------