diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrew Martin (c) 2017 + +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 Andrew Martin 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,1 @@ +# prim-array 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/compact-mutable.cabal b/compact-mutable.cabal new file mode 100644 --- /dev/null +++ b/compact-mutable.cabal @@ -0,0 +1,44 @@ +name: compact-mutable +version: 0.1 +synopsis: Mutable arrays living on the compact heap +homepage: https://github.com/andrewthad/compact-mutable#readme +license: BSD3 +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2017 Andrew Martin +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Data.Primitive.Compact + build-depends: + base >= 4.10 && < 5 + , primitive >= 0.6.2 && < 0.7 + , prim-array >= 0.2 && < 0.3 + , ghc-prim >= 0.5 && < 0.6 + , ghc-compact >= 0.1 && < 0.2 + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base + , prim-array + , containers + , transformers + , primitive + , compact-mutable + , ghc-compact + , ghc-prim + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/andrewthad/compact-mutable diff --git a/src/Data/Primitive/Compact.hs b/src/Data/Primitive/Compact.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Compact.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Strict #-} + +{-# OPTIONS_GHC -O2 #-} + +module Data.Primitive.Compact + ( CompactMutableArray(..) + , CompactMutablePrimArray(..) -- should not actually export this + , CompactMutableByteArray(..) + , ContractedMutableArray(..) + , CompactPrimRef + , Token + , Contractible(..) + , Heap(..) + , withToken + , newCompactArray + , newContractedArray + , newCompactArrayCopier + , newCompactPrimRef + , newCompactPrimArray + , newCompactPrimArrayCopier + , readCompactArray + , writeCompactArray + , copyCompactMutableArray + , copyContractedMutableArray + , getSizeOfCompact + , readContractedArray + , writeContractedArray + -- * Unsafe things + , compactAddGeneral + , unsafeInsertCompactArray + , unsafeInsertContractedArray + , printCompactArrayAddrs + , unsafeUnliftedToAddr + , unsafeUnliftedFromAddr + ) where + +import GHC.Int +import GHC.Prim +import GHC.Compact +import Control.Monad +import Control.Monad.Primitive +import Data.Primitive +import Data.Primitive.SmallArray +import Data.Primitive.Array +import Data.Primitive.PrimArray +import Data.Primitive.Types +import Data.Primitive.PrimRef +import Data.Primitive.ByteArray +import Data.Primitive.UnliftedArray +import Data.Proxy +import Unsafe.Coerce +import Debug.Trace +import GHC.Conc (pseq) +import GHC.Ptr (Ptr(..)) +import GHC.Word (Word(..)) +import GHC.Types + +-- | This represents a mutable array in a compact region. +newtype CompactMutableArray s (a :: Heap -> *) (c :: Heap) + = CompactMutableArray (MutablePrimArray s Addr) -- (Array (a c)) +newtype CompactPrimRef s a c + = CompactPrimRef (PrimRef s a) +newtype CompactMutablePrimArray s a c + = CompactMutablePrimArray (MutablePrimArray s a) +newtype CompactMutableByteArray s c + = CompactMutableByteArray (MutableByteArray s) + +-- | A contracted array is like a prim array, except that +-- it talks about data structures who have data on a +-- compact heap. +data ContractedMutableArray (a :: * -> Heap -> *) s (c :: Heap) + = ContractedMutableArray + (MutableByteArray# s) + (MutableArrayArray# s) +data Token c = Token Compact# +data Heap + +-- withToken :: PrimMonad m => (forall c. Token c -> m x) -> m x +-- withToken f = compactNewGeneral >>= f + +withToken :: PrimMonad m => (forall c. Token c -> m x) -> m x +withToken f = do + !token <- compactNewGeneral + !x <- f token + !_ <- compactAddGeneral token (42 :: Int) + return x + +compactNewGeneral# :: Word# -> State# s -> (# State# s, Compact# #) +compactNewGeneral# = unsafeCoerce compactNew# + +compactAddGeneral# :: Compact# -> a -> State# s -> (# State# s, a #) +compactAddGeneral# = unsafeCoerce compactAdd# + +compactSizeGeneral# :: Compact# -> State# s -> (# State# s, Word# #) +compactSizeGeneral# = unsafeCoerce compactSize# + + +-- Does not typecheck +-- addByteArray :: Compact# -> State# RealWorld -> State# RealWorld +-- addByteArray c s1 = case newByteArray# 50# s1 of +-- (# s2, arr #) -> case compactAdd# c arr s2 of +-- (# s3, arr2 #) -> s3 + +compactAddGeneral :: PrimMonad m => Token c -> a -> m a +compactAddGeneral (Token compact#) !a = primitive $ \ !s -> + compactAddGeneral# compact# a s + +-- Notice that @c@ is universally quantified here. +compactNewGeneral :: PrimMonad m => m (Token c) +compactNewGeneral = primitive $ \ !s -> + case compactNewGeneral# 31268## s of { (# !s1, !c #) -> + (# s1, Token c #) } + +getSizeOfCompact :: PrimMonad m => Token c -> m Word +getSizeOfCompact (Token compact#) = primitive $ \s0 -> + case compactSizeGeneral# compact# s0 of (# s1, sz #) -> (# s1, W# sz #) + +-- | Create a new mutable array. +newCompactPrimRef :: (PrimMonad m, Prim a) + => Token c + -> a -- ^ initial value + -> m (CompactPrimRef (PrimState m) a c) +newCompactPrimRef !c !a = do + !ref1 <- newPrimRef a + !ref2 <- compactAddGeneral c ref1 + return (CompactPrimRef ref2) + +newCompactPrimArray :: (PrimMonad m, Prim a) + => Token c + -> Int -- ^ Length + -> m (CompactMutablePrimArray (PrimState m) a c) +newCompactPrimArray !c !n = do + !ref1 <- newPrimArray n + !ref2 <- compactAddGeneral c ref1 + return (CompactMutablePrimArray ref2) + +newCompactPrimArrayCopier :: (PrimMonad m, Prim a) + => Token c + -> Int -- ^ Length + -> m (m (CompactMutablePrimArray (PrimState m) a c)) +newCompactPrimArrayCopier !c !n = do + !marr1 <- newPrimArray n + return $ do + !marr2 <- compactAddGeneral c marr1 + return (CompactMutablePrimArray marr2) + +-- | Create a new mutable array. Notice that we do not need a +-- default value. +newCompactArray :: (PrimMonad m) + => Token c + -> Int + -> m (CompactMutableArray (PrimState m) a c) +newCompactArray !c !n = do + -- it is unfortunate that we have to do this allocation twice, + -- once on the normal heap and once on the compact heap. + !marr1 <- newPrimArray n + !marr2 <- compactAddGeneral c marr1 + return (CompactMutableArray marr2) + +newContractedArray :: forall m a c. (PrimMonad m, Contractible a) + => Token c + -> Int + -> m (ContractedMutableArray a (PrimState m) c) +newContractedArray !c !n = do + -- it is unfortunate that we have to do this allocation twice, + -- once on the normal heap and once on the compact heap. + MutableByteArray ba <- compactAddGeneral c =<< newByteArray (n * I# (unsafeContractedByteCount# (proxy# :: Proxy# a))) + UnliftedArray aa <- compactAddGeneral c =<< unsafeFreezeUnliftedArray =<< newUnliftedArray (n * I# (unsafeContractedUnliftedPtrCount# (proxy# :: Proxy# a))) (MutableByteArray ba) + return (ContractedMutableArray ba (unsafeCoerce# aa)) + +newCompactArrayCopier :: PrimMonad m + => Token c + -> Int + -> m (m (CompactMutableArray (PrimState m) a c)) +newCompactArrayCopier !c !n = do + !marr1 <- newPrimArray n + return $ do + !marr2 <- compactAddGeneral c marr1 + return (CompactMutableArray marr2) + +writeCompactArray :: PrimMonad m + => CompactMutableArray (PrimState m) a c + -> Int + -> a c -- ^ please do not pick something that has been unboxed into + -- a data constructor, segfaults lie that way. + -> m () +writeCompactArray (CompactMutableArray !marr) !ix !val = do + let !addr = unsafeToAddr val + -- traceM (showAddr addr) + writePrimArray marr ix addr +{-# INLINE writeCompactArray #-} + +readCompactArray :: PrimMonad m + => CompactMutableArray (PrimState m) a c + -> Int + -> m (a c) +readCompactArray (CompactMutableArray !marr) !ix = do + !addr <- readPrimArray marr ix + return (unsafeFromAddr addr) +{-# INLINE readCompactArray #-} + +-- | Insert an element in the array, shifting the values right +-- of the index. The array size should be big enough for this +-- shift, this is not checked. +unsafeInsertCompactArray :: PrimMonad m + => Int -- ^ Size of the original array + -> Int -- ^ Index + -> a c -- ^ Value + -> CompactMutableArray (PrimState m) a c -- ^ Array to modify + -> m () +unsafeInsertCompactArray !sz !i !x (CompactMutableArray !marr) = do + copyMutablePrimArray marr (i + 1) marr i (sz - i) + writePrimArray marr i (unsafeToAddr x) +{-# INLINE unsafeInsertCompactArray #-} + +unsafeInsertContractedArray :: forall m a c. (PrimMonad m, Contractible a) + => Int -- ^ Size of the original array + -> Int -- ^ Index + -> a (PrimState m) c -- ^ Value + -> ContractedMutableArray a (PrimState m) c -- ^ Array to modify + -> m () +unsafeInsertContractedArray !sz !i !x !carr = do + copyContractedMutableArray carr (i + 1) carr i (sz - i) + writeContractedArray carr i x +{-# INLINE unsafeInsertContractedArray #-} + +copyContractedMutableArray + :: forall m a c. (PrimMonad m, Contractible a) + => ContractedMutableArray a (PrimState m) c -- ^ destination + -> Int -- ^ destination offset + -> ContractedMutableArray a (PrimState m) c -- ^ source + -> Int -- ^ source offset + -> Int -- ^ length + -> m () +copyContractedMutableArray (ContractedMutableArray destB destA) (I# destOff) (ContractedMutableArray srcB srcA) (I# srcOff) (I# len) + = primitive_ $ \s1 -> case copyMutableByteArray# srcB (srcOff *# (unsafeContractedByteCount# (proxy# :: Proxy# a))) destB (destOff *# (unsafeContractedByteCount# (proxy# :: Proxy# a))) (len *# (unsafeContractedByteCount# (proxy# :: Proxy# a))) s1 of + s2 -> copyMutableArrayArray# srcA (srcOff *# (unsafeContractedUnliftedPtrCount# (proxy# :: Proxy# a))) destA (destOff *# (unsafeContractedUnliftedPtrCount# (proxy# :: Proxy# a))) (len *# (unsafeContractedUnliftedPtrCount# (proxy# :: Proxy# a))) s2 +{-# INLINE copyContractedMutableArray #-} + +copyCompactMutableArray + :: PrimMonad m + => CompactMutableArray (PrimState m) a c -- ^ destination + -> Int -- ^ destination offset + -> CompactMutableArray (PrimState m) a c -- ^ source + -> Int -- ^ source offset + -> Int -- ^ length + -> m () +copyCompactMutableArray (CompactMutableArray !dest) !doff (CompactMutableArray !src) !soff !len + = copyMutablePrimArray dest doff src soff len +{-# INLINE copyCompactMutableArray #-} + +unsafeToAddr :: a -> Addr +unsafeToAddr a = pseq a (Addr (unsafeCoerce# a :: Addr#)) +{-# INLINE unsafeToAddr #-} + +-- not joking when I say that this is about as unsafe as it gets. +unsafeFromAddr :: Addr -> a +unsafeFromAddr (Addr x) = unsafeCoerce# x +{-# INLINE unsafeFromAddr #-} + +-- make sure this is actually sound. I'm pretty sure that +-- unlifted data must already be fully evaluated because of +-- how its calling convention works. +unsafeUnliftedToAddr :: forall (a :: TYPE 'UnliftedRep). a -> Addr +unsafeUnliftedToAddr a = Addr (unsafeCoerce# a :: Addr#) +{-# INLINE unsafeUnliftedToAddr #-} + +unsafeUnliftedFromAddr :: forall (a :: TYPE 'UnliftedRep). Addr -> a +unsafeUnliftedFromAddr (Addr x) = unsafeCoerce# x +{-# INLINE unsafeUnliftedFromAddr #-} + +showAddr :: Addr -> String +showAddr (Addr a#) = show (Ptr a#) + +printCompactArrayAddrs :: CompactMutableArray RealWorld a c -> IO () +printCompactArrayAddrs (CompactMutableArray marr) = do + n <- getSizeofMutablePrimArray marr + forM_ [0..(n - 1)] $ \ix -> do + addr <- readPrimArray marr ix + putStrLn (showAddr addr) + +writeContractedArray :: (PrimMonad m, Contractible a) + => ContractedMutableArray a (PrimState m) c -> Int -> a (PrimState m) c -> m () +writeContractedArray (ContractedMutableArray ba aa) (I# ix) r = + primitive_ $ \s -> writeContractedArray# ba aa ix r s + +readContractedArray :: (PrimMonad m, Contractible a) + => ContractedMutableArray a (PrimState m) c -> Int -> m (a (PrimState m) c) +readContractedArray (ContractedMutableArray ba aa) (I# ix) = + primitive $ \s -> readContractedArray# ba aa ix s + +-- | Super dangerous typeclass. Be careful trying to +-- define instances. +class Contractible (a :: * -> Heap -> *) where + unsafeContractedUnliftedPtrCount# :: Proxy# a -> Int# + -- ^ Number of unlifted pointers + unsafeContractedByteCount# :: Proxy# a -> Int# + -- ^ size of serialization, in bytes + writeContractedArray# :: MutableByteArray# s -> MutableArrayArray# s -> Int# -> a s c -> State# s -> State# s + -- ^ remember that the int provided here gives an index in + -- elements, not in bytes + readContractedArray# :: MutableByteArray# s -> MutableArrayArray# s -> Int# -> State# s -> (# State# s, a s c #) + -- ^ index is in elements, not bytes + +-- instance Contractible (CompactMutableArray m a) where +-- unsafeContractedUnliftedPtrCount _ = 1 +-- unsafeContractedByteCount _ = 0 +-- unsafeWriteContractedArray (ContractedMutableArray _ marr#) (I# ix) (CompactMutableArray (MutablePrimArray arr#)) = +-- primitive_ (\s -> writeMutableByteArrayArray# marr# ix arr# s) +-- unsafeReadContractedArray (ContractedMutableArray _ marr#) (I# ix) = +-- primitive (\s -> case readMutableByteArrayArray# marr# ix s of +-- (# s', arr# #) -> (# s', CompactMutableArray (MutablePrimArray arr# ) #) +-- ) + + + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -O2 #-} + +import Data.Primitive.Compact +import GHC.Compact +import GHC.Prim +import Data.Word +import Data.Primitive.Array +import Data.Primitive.PrimArray +import Data.Primitive.ByteArray +import Data.Primitive.PrimRef +import Data.Primitive +import Data.Functor.Identity +import Data.Int +import Control.Monad + +main :: IO () +main = do + putStrLn "Running compact-mutable tests" + putStrLn "Trying normal compact functions as sanity check" + _ <- newArray 13 (44 :: Int) >>= unsafeFreezeArray >>= compact + _ <- newArray 11 (42 :: Int) >>= (\m -> freezeArray m 0 5) >>= compact + nums <- newPrimArray 15 :: IO (MutablePrimArray RealWorld Int64) + writePrimArray nums 0 58 + nums2 <- fmap getCompact $ compact nums + nums2Alias <- fmap getCompact $ compact nums2 + writePrimArray nums2Alias 0 57 + originalVal <- readPrimArray nums 0 + copyVal <- readPrimArray nums2 0 + aliasVal <- readPrimArray nums2Alias 0 + when (originalVal /= 58) $ fail "original value wrong" + when (copyVal /= 58) $ fail "copy value wrong" + when (aliasVal /= 57) $ fail "alias value wrong" + withToken $ \token -> do + -- putStrLn "creating array" + -- _ <- newCompactArray token 5 + -- putStrLn "creating mutable array" + -- _ <- newCompactArray token 5 + -- putStrLn "creating array of arrays" + -- c1 <- newCompactArray token 12 + -- c2 <- newCompactArray token 5 + -- writeCompactArray c1 0 (Yes c2) + -- unsafeInsertCompactArray 4 2 (Yes c2) c1 + -- writeCompactArray c1 1 No + -- x <- readCompactArray c1 1 + -- case x of + -- No -> return () + -- Yes _ -> fail "did not get expected value" + -- copyCompactMutableArray c1 0 c1 4 3 + -- c3 <- newCompactArray token 16 + -- _ <- compactAddGeneral token (Identity c1) + -- _ <- compactAddGeneral token (Identity c3) + -- putStrLn "creating PrimRef" + p1 <- Ref <$> newPrimRef (12 :: Word16) + p2 <- compactAddGeneral token p1 + -- p9 <- compactAddGeneral token (Thing (12 :: Word32)) + -- -- !p3 <- compactAddGeneral token p2 + -- _ <- newCompactArray token 3 + putStrLn "attempting large loop" + arr <- newCompactArray token 10000000 + let go !n = if n < 10000000 + then do + !p3 <- compactAddGeneral token (Thing n) + writeCompactArray arr n p3 + go (n + 1) + else return () + go 0 + -- printCompactArrayAddrs arr + let goRead !n = if n < 10000000 + then do + Thing val <- readCompactArray arr n + -- val <- readPrimRef r + if val == n + then return () + else fail "found value not equal to n" + goRead (n + 1) + else return () + goRead 0 + putStrLn "finished large loop" + putStrLn "aliasing behavior" + a1 <- newCompactArray token 10 + writeCompactArray a1 0 (Thing (79 :: Int)) + a2 <- compactAddGeneral token a1 + a3 <- compactAddGeneral token a2 + writeCompactArray a3 0 (Thing (74 :: Int)) + Thing n <- readCompactArray a1 0 + when (n /= 74) $ fail "wrong value of n" + putStrLn "finished aliasing behavior" + putStrLn "testing contractible array" + k1 <- newContractedArray token 2 + k5 <- newContractedArray token 3 + writeContractedArray k1 0 (Foo 55 k1) + writeContractedArray k1 1 (Foo 12 k5) + writeContractedArray k5 0 (Foo 33 k5) + writeContractedArray k5 1 (Foo 42 k1) + Foo n k2 <- readContractedArray k1 0 + Foo m k3 <- readContractedArray k2 0 + Foo _ k6 <- readContractedArray k5 0 + Foo _ k7 <- readContractedArray k5 1 + Foo _ _ <- readContractedArray k6 0 + Foo _ _ <- readContractedArray k7 1 + unsafeInsertContractedArray 2 1 (Foo 124 k1) k5 + Foo _ k8 <- readContractedArray k5 2 + Foo _ _ <- readContractedArray k8 1 + Foo _ k9 <- readContractedArray k5 1 + Foo _ _ <- readContractedArray k9 1 + if n == 55 + then return () + else fail "n should be 55" + if m == 55 + then return () + else fail "m should be 55" + putStrLn "successful contractible array" + return () + +-- Note: making types like this to put in a compact array is not +-- typically safe. Do not do it unless you understand how the compact +-- heap works. +data Thing a (c :: Heap) = Thing !a +data MaybeArray (c :: Heap) = No | Yes (CompactMutableArray RealWorld MaybeArray c) +data Ref (c :: Heap) = Ref !(PrimRef RealWorld Word16) + +data Foo s c = Foo + {-# UNPACK #-} !Int + {-# UNPACK #-} !(ContractedMutableArray s (Foo s) c) + +instance Contractible (Foo s) where + unsafeSizeOfContractedElement _ = sizeOf (undefined :: Int) * 2 + unsafeWriteContractedArray (ContractedMutableArray marr) ix (Foo n (ContractedMutableArray (MutableByteArray nodes))) = do + let machIx = ix * 2 + writeByteArray marr (machIx + 0) n + writeByteArray marr (machIx + 1) (unsafeUnliftedToAddr nodes) + unsafeReadContractedArray (ContractedMutableArray marr) ix = do + let machIx = ix * 2 + a <- readByteArray marr (machIx + 0) + f <- readByteArray marr (machIx + 1) + return (Foo a (ContractedMutableArray (MutableByteArray (unsafeUnliftedFromAddr f)))) + +