compact-mutable (empty) → 0.1

raw patch · 6 files changed

+545/−0 lines, 6 filesdep +basedep +compact-mutabledep +containerssetup-changed

Dependencies added: base, compact-mutable, containers, ghc-compact, ghc-prim, prim-array, primitive, transformers

Files

LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
compact-mutable.cabal +44/−0
src/Data/Primitive/Compact.hs +325/−0
test/Main.hs +143/−0

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,1 @@+# prim-array

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ compact-mutable.cabal view

@@ -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

+ src/Data/Primitive/Compact.hs view

@@ -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# ) #)+--     )+  ++

+ test/Main.hs view

@@ -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))))++