compact (empty) → 0.1.0.0

raw patch · 7 files changed

+277/−0 lines, 7 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, compact, directory, ghc-compact

Files

• ChangeLog.md +5/−0
• Data/Compact.hs +19/−0
• Data/Compact/Serialize.hs +153/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• compact.cabal +42/−0
• tests/compact-test.hs +26/−0

@@ -0,0 +1,5 @@+# Revision history for compact++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,19 @@+module Data.Compact (+    -- * The 'Compact' type+    Compact,++    -- * Compacting data+    compact,+    compactWithSharing,+    compactAdd,+    compactAddWithSharing,+    compactSized,++    -- * Inspecting a Compact+    getCompact,+    inCompact,+    isCompact,+    compactSize,+) where++import GHC.Compact

@@ -0,0 +1,153 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Compact.Serialize+    ( writeCompact, unsafeReadCompact+    , hPutCompact, hUnsafeGetCompact+    ) where++import Type.Reflection+import Control.Monad+import Data.Monoid+import Data.IORef+import Data.Word+import System.IO++import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc++import qualified Data.Binary as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BSU+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Builder as BSB++import GHC.Compact+import GHC.Compact.Serialized++newtype CompactFile a = CompactFile (SerializedCompact a)++-- NB: This instance cannot be put on SerializedCompact as+-- ghc-compact does not have a binary dependency+instance (Typeable a) => B.Binary (CompactFile a) where+    get = do+        SomeTypeRep tyrep <- B.get+        case tyrep `eqTypeRep` typeRep @a of+          Just HRefl -> CompactFile <$> getSerializedCompact+          Nothing -> fail $+            "Data.Compact.Serialized: expected " ++ show (typeRep @a) +++            " but got " ++ show tyrep+    put (CompactFile a) = B.put (typeRep @a) >> putSerializedCompact a++putPtr :: Ptr a -> B.Put+putPtr = B.put @Word64 . fromIntegral . ptrToWordPtr++getPtr :: B.Get (Ptr a)+getPtr = wordPtrToPtr . fromIntegral <$> B.get @Word64++getList :: B.Get a -> B.Get [a]+getList getElem = do+    n <- B.get @Int+    replicateM n getElem++putList :: (a -> B.Put) -> [a] -> B.Put+putList putElem xs = do+    B.put @Int (length xs)+    mapM_ putElem xs++getSerializedCompact :: B.Get (SerializedCompact a)+getSerializedCompact = SerializedCompact <$> getList getBlock <*> getPtr+  where+    getBlock :: B.Get (Ptr a, Word)+    getBlock = (,) <$> getPtr <*> B.get++putSerializedCompact :: SerializedCompact a -> B.Put+putSerializedCompact (SerializedCompact a b) = putList putBlock a <> putPtr b+  where+    putBlock :: (Ptr a, Word) -> B.Put+    putBlock (ptr, len) = putPtr ptr <> B.put len++-- | Write a compact region to a file.  The resulting file can+-- be read back into memory using 'unsafeReadCompact'.+--+writeCompact :: Typeable a => FilePath -> Compact a -> IO ()+writeCompact fname compact =+    withFile fname WriteMode $ \h -> hPutCompact h compact++-- | Write a compact region to a 'Handle'.  The compact region+-- can be read out of the handle by using 'hUnsafeGetCompact'.+--+hPutCompact :: Typeable a => Handle -> Compact a -> IO ()+hPutCompact hdl compact =+    withSerializedCompact compact $ \scompact -> do+        let bs = B.encode $ CompactFile scompact+        -- By writing out the length of the metadata segment, we+        -- can read out a single word, read out the metadata segment,+        -- and then immediately start blasting further data from+        -- the handle into the memory region where the compact+        -- is going to go.  Otherwise, we have to indirect through+        -- a lazy bytestring which has a cost.+        hPutStorable hdl (fromIntegral (BSL.length bs) :: Int)+        BSL.hPut hdl bs+        let putBlock (ptr, len) = hPutBuf hdl ptr (fromIntegral len)+        mapM_ putBlock (serializedCompactBlockList scompact)++-- | Read out a compact region that was serialized to a file.+-- See 'hUnsafeGetCompact' for safety considerations when using this function.+--+unsafeReadCompact :: Typeable a => FilePath -> IO (Either String (Compact a))+unsafeReadCompact fname =+    withFile fname ReadMode $ \hdl -> hUnsafeGetCompact hdl++-- | Read out a compact region from a handle.+--+-- Compact regions written to handles this way are subject to some+-- restrictions:+--+--  * Our binary representation contains direct pointers to the info+--    tables of objects in the region.  This means that the info tables+--    of the receiving process must be laid out in exactly the same+--    way as from the original process; in practice, this means using+--    static linking, using the exact same binary and turning off ASLR.  This+--    API does NOT do any safety checking and will probably segfault if you+--    get it wrong.  DO NOT run this on untrusted input.+--+--  * You must read out the value at the correct type.  We will+--    check this for you and raise an error if the types do not match+--    (this is what the 'Typeable' constraint is for).+--+hUnsafeGetCompact+    :: forall a. Typeable a+    => Handle -> IO (Either String (Compact a))+hUnsafeGetCompact hdl = do+    l <- hGetStorable hdl+    mbs <- BSL.hGet hdl (l :: Int)+    case B.decodeOrFail @(CompactFile a) mbs of+      Left (_, _, err) -> return $ Left err+      Right (rest, _, CompactFile scompact)+        | not (BSL.null rest) -> return . Left+            $ "Had " ++ show (BSL.length rest) ++ " bytes of leftover metadata"+        | otherwise  -> do+          res <- importCompact scompact $ \ptr l ->+                    void $ hGetBuf hdl ptr (fromIntegral l)+          case res of+            Nothing -> return $ Left "Failed to import compact"+            Just compact -> return $ Right compact++hPutStorable :: forall a. Storable a => Handle -> a -> IO ()+hPutStorable h a =+    alloca $ \ptr -> do+        poke ptr a+        hPutBuf h ptr (sizeOf (undefined :: a))++hGetStorable :: forall a. Storable a => Handle -> IO a+hGetStorable h =+    alloca $ \ptr -> do+        hGetBuf h ptr (sizeOf (undefined :: a))+        peek ptr

@@ -0,0 +1,30 @@+Copyright (c) 2017, Edward Z. Yang++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 Edward Z. Yang 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.

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

@@ -0,0 +1,42 @@+name:                compact+version:             0.1.0.0+synopsis:            Non-GC'd, contiguous storage for immutable data structures+description:+    This package provides user-facing APIs for working with+    "compact regions", which hold a fully evaluated Haskell object graph.+    These regions maintain the invariant that no pointers live inside the struct+    that point outside it, which ensures efficient garbage collection without+    ever reading the structure contents (effectively, it works as a manually+    managed "oldest generation" which is never freed until the whole is+    released).++    This package is currently highly experimental, but we hope it may+    be useful to some people.  It is GHC 8.2 only.  The bare-bones library+    that ships with GHC is ghc-compact.+license:             BSD3+license-file:        LICENSE+author:              Edward Z. Yang, Ben Gamari+maintainer:          ezyang@mit.edu, ben@smart-cactus.org+copyright:           (c) 2017 Edward Z. Yang, Ben Gamari+category:            Data+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  exposed-modules:     Data.Compact+                       Data.Compact.Serialize+  build-depends:       base       >= 4.10 && < 4.11,+                       ghc-compact,+                       -- TODO: SomeTypeRep instance is in unreleased version+                       -- of binary that is bundled with GHC dev branch+                       binary     >= 0.8.4.1 && < 0.9,+                       bytestring >= 0.10 && < 0.11+  default-language:    Haskell2010++test-suite compact-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             compact-test.hs+  build-depends:       compact, base, directory+  default-language:    Haskell2010

@@ -0,0 +1,26 @@+{-# LANGUAGE TypeApplications #-}++import Data.Compact+import Data.Compact.Serialize+import Control.Exception+import System.IO+import System.Directory+import System.Mem+import Control.Monad++main = do+    tmp <- getTemporaryDirectory+    let val = ("hello", 1, 42, 42, Just 42) :: (String, Int, Int, Integer, Maybe Int)+    c <- compact val+    (fp, h) <- openTempFile tmp "compact.bin"+    hPutCompact h c+    hClose h+    performMajorGC+    r <- unsafeReadCompact @(String, Int, Int, Integer, Maybe Int) fp+    c' <- case r of+            Left err -> fail err+            Right x -> return x+    removeFile fp+    print (getCompact c')+    when (val /= getCompact c') $ fail "did not match"+    putStrLn "OK"