diff --git a/GHC/Compact.hs b/GHC/Compact.hs new file mode 100644 --- /dev/null +++ b/GHC/Compact.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-name-shadowing #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Compact +-- Copyright : (c) The University of Glasgow 2001-2009 +-- (c) Giovanni Campagna 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : unstable +-- Portability : non-portable (GHC Extensions) +-- +-- This module provides a data structure, called a 'Compact', for +-- holding immutable, fully evaluated data in a consecutive block of memory. +-- Compact regions are good for two things: +-- +-- 1. Data in a compact region is not traversed during GC; any +-- incoming pointer to a compact region keeps the entire region +-- live. Thus, if you put a long-lived data structure in a compact +-- region, you may save a lot of cycles during major collections, +-- since you will no longer be (uselessly) retraversing this +-- data structure. +-- +-- 2. Because the data is stored contiguously, you can easily +-- dump the memory to disk and/or send it over the network. +-- For applications that are not bandwidth bound (GHC's heap +-- representation can be as much of a x4 expansion over a +-- binary serialization), this can lead to substantial speedups. +-- +-- For example, suppose you have a function @loadBigStruct :: IO BigStruct@, +-- which loads a large data structure from the file system. You can "compact" +-- the structure with the following code: +-- +-- @ +-- do r <- 'compact' =<< loadBigStruct +-- let x = 'getCompact' r :: BigStruct +-- -- Do things with x +-- @ +-- +-- Note that 'compact' will not preserve internal sharing; use +-- 'compactWithSharing' (which is 10x slower) if you have cycles and/or +-- must preserve sharing. The 'Compact' pointer @r@ can be used +-- to add more data to a compact region; see 'compactAdd' or +-- 'compactAddWithSharing'. +-- +-- The implementation of compact regions is described by: +-- +-- * Edward Z. Yang, Giovanni Campagna, Ömer Ağacan, Ahmed El-Hassany, Abhishek +-- Kulkarni, Ryan Newton. \"/Efficient communication and Collection with Compact +-- Normal Forms/\". In Proceedings of the 20th ACM SIGPLAN International +-- Conference on Functional Programming. September 2015. +-- +-- This library is supported by GHC 8.2 and later. + +module GHC.Compact ( + -- * The Compact type + Compact(..), + + -- * Compacting data + compact, + compactWithSharing, + compactAdd, + compactAddWithSharing, + + -- * Inspecting a Compact + getCompact, + inCompact, + isCompact, + compactSize, + + -- * Other utilities + compactResize, + + -- * Internal operations + mkCompact, + compactSized, + ) where + +import Control.Concurrent.MVar +import GHC.Prim +import GHC.Types + +-- | A 'Compact' contains fully evaluated, pure, immutable data. +-- +-- 'Compact' serves two purposes: +-- +-- * Data stored in a 'Compact' has no garbage collection overhead. +-- The garbage collector considers the whole 'Compact' to be alive +-- if there is a reference to any object within it. +-- +-- * A 'Compact' can be serialized, stored, and deserialized again. +-- The serialized data can only be deserialized by the exact binary +-- that created it, but it can be stored indefinitely before +-- deserialization. +-- +-- Compacts are self-contained, so compacting data involves copying +-- it; if you have data that lives in two 'Compact's, each will have a +-- separate copy of the data. +-- +-- The cost of compaction is similar to the cost of GC for the same +-- data, but it is performed only once. However, because +-- "GHC.Compact.compact" does not stop-the-world, retaining internal +-- sharing during the compaction process is very costly. The user +-- can choose whether to 'compact' or 'compactWithSharing'. +-- +-- When you have a @'Compact' a@, you can get a pointer to the actual object +-- in the region using "GHC.Compact.getCompact". The 'Compact' type +-- serves as handle on the region itself; you can use this handle +-- to add data to a specific 'Compact' with 'compactAdd' or +-- 'compactAddWithSharing' (giving you a new handle which corresponds +-- to the same compact region, but points to the newly added object +-- in the region). At the moment, due to technical reasons, +-- it's not possible to get the @'Compact' a@ if you only have an @a@, +-- so make sure you hold on to the handle as necessary. +-- +-- Data in a compact doesn't ever move, so compacting data is also a +-- way to pin arbitrary data structures in memory. +-- +-- There are some limitations on what can be compacted: +-- +-- * Functions. Compaction only applies to data. +-- +-- * Pinned 'ByteArray#' objects cannot be compacted. This is for a +-- good reason: the memory is pinned so that it can be referenced by +-- address (the address might be stored in a C data structure, for +-- example), so we can't make a copy of it to store in the 'Compact'. +-- +-- * Objects with mutable pointer fields (e.g. 'Data.IORef.IORef', +-- 'GHC.Array.MutableArray') also cannot be compacted, because subsequent +-- mutation would destroy the property that a compact is self-contained. +-- +-- If compaction encounters any of the above, a 'CompactionFailed' +-- exception will be thrown by the compaction operation. +-- +data Compact a = Compact Compact# a (MVar ()) + -- we can *read* from a Compact without taking a lock, but only + -- one thread can be writing to the compact at any given time. + -- The MVar here is to enforce mutual exclusion among writers. + -- Note: the MVar protects the Compact# only, not the pure value 'a' + +-- | Make a new 'Compact' object, given a pointer to the true +-- underlying region. You must uphold the invariant that @a@ lives +-- in the compact region. +-- +mkCompact + :: Compact# -> a -> State# RealWorld -> (# State# RealWorld, Compact a #) +mkCompact compact# a s = + case unIO (newMVar ()) s of { (# s1, lock #) -> + (# s1, Compact compact# a lock #) } + where + unIO (IO a) = a + +-- | Transfer @a@ into a new compact region, with a preallocated size, +-- possibly preserving sharing or not. If you know how big the data +-- structure in question is, you can save time by picking an appropriate +-- block size for the compact region. +-- +compactSized :: Int -> Bool -> a -> IO (Compact a) +compactSized (I# size) share a = IO $ \s0 -> + case compactNew# (int2Word# size) s0 of { (# s1, compact# #) -> + case compactAddPrim compact# a s1 of { (# s2, pk #) -> + mkCompact compact# pk s2 }} + where + compactAddPrim + | share = compactAddWithSharing# + | otherwise = compactAdd# + +-- | Retrieve a direct pointer to the value pointed at by a 'Compact' reference. +-- If you have used 'compactAdd', there may be multiple 'Compact' references +-- into the same compact region. Upholds the property: +-- +-- > inCompact c (getCompact c) == True +-- +getCompact :: Compact a -> a +getCompact (Compact _ obj _) = obj + +-- | Compact a value. /O(size of unshared data)/ +-- +-- If the structure contains any internal sharing, the shared data +-- will be duplicated during the compaction process. This will +-- not terminate if the structure contains cycles (use 'compactWithSharing' +-- instead). +-- +-- The object in question must not contain any functions or data with mutable +-- pointers; if it does, 'compact' will raise an exception. In the future, we +-- may add a type class which will help statically check if this is the case or +-- not. +-- +compact :: a -> IO (Compact a) +compact = compactSized 31268 False + +-- | Compact a value, retaining any internal sharing and +-- cycles. /O(size of data)/ +-- +-- This is typically about 10x slower than 'compact', because it works +-- by maintaining a hash table mapping uncompacted objects to +-- compacted objects. +-- +-- The object in question must not contain any functions or data with mutable +-- pointers; if it does, 'compact' will raise an exception. In the future, we +-- may add a type class which will help statically check if this is the case or +-- not. +-- +compactWithSharing :: a -> IO (Compact a) +compactWithSharing = compactSized 31268 True + +-- | Add a value to an existing 'Compact'. This will help you avoid +-- copying when the value contains pointers into the compact region, +-- but remember that after compaction this value will only be deallocated +-- with the entire compact region. +-- +-- Behaves exactly like 'compact' with respect to sharing and what data +-- it accepts. +-- +compactAdd :: Compact b -> a -> IO (Compact a) +compactAdd (Compact compact# _ lock) a = withMVar lock $ \_ -> IO $ \s -> + case compactAdd# compact# a s of { (# s1, pk #) -> + (# s1, Compact compact# pk lock #) } + +-- | Add a value to an existing 'Compact', like 'compactAdd', +-- but behaving exactly like 'compactWithSharing' with respect to sharing and +-- what data it accepts. +-- +compactAddWithSharing :: Compact b -> a -> IO (Compact a) +compactAddWithSharing (Compact compact# _ lock) a = + withMVar lock $ \_ -> IO $ \s -> + case compactAddWithSharing# compact# a s of { (# s1, pk #) -> + (# s1, Compact compact# pk lock #) } + +-- | Check if the second argument is inside the passed 'Compact'. +-- +inCompact :: Compact b -> a -> IO Bool +inCompact (Compact buffer _ _) !val = + IO (\s -> case compactContains# buffer val s of + (# s', v #) -> (# s', isTrue# v #) ) + +-- | Check if the argument is in any 'Compact'. If true, the value in question +-- is also fully evaluated, since any value in a compact region must +-- be fully evaluated. +-- +isCompact :: a -> IO Bool +isCompact !val = + IO (\s -> case compactContainsAny# val s of + (# s', v #) -> (# s', isTrue# v #) ) + +-- | Returns the size in bytes of the compact region. +-- +compactSize :: Compact a -> IO Word +compactSize (Compact buffer _ lock) = withMVar lock $ \_ -> IO $ \s0 -> + case compactSize# buffer s0 of (# s1, sz #) -> (# s1, W# sz #) + +-- | *Experimental.* This function doesn't actually resize a compact +-- region; rather, it changes the default block size which we allocate +-- when the current block runs out of space, and also appends a block +-- to the compact region. +-- +compactResize :: Compact a -> Word -> IO () +compactResize (Compact oldBuffer _ lock) (W# new_size) = + withMVar lock $ \_ -> IO $ \s -> + case compactResize# oldBuffer new_size s of + s' -> (# s', () #) diff --git a/GHC/Compact/Serialized.hs b/GHC/Compact/Serialized.hs new file mode 100644 --- /dev/null +++ b/GHC/Compact/Serialized.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Compact.Serialized +-- Copyright : (c) The University of Glasgow 2001-2009 +-- (c) Giovanni Campagna 2015 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : unstable +-- Portability : non-portable (GHC Extensions) +-- +-- This module contains support for serializing a Compact for network +-- transmission and on-disk storage. +-- +-- /Since: 1.0.0/ + +module GHC.Compact.Serialized( + SerializedCompact(..), + withSerializedCompact, + importCompact, + importCompactByteStrings, +) where + +import GHC.Prim +import GHC.Types +import GHC.Word (Word8) + +import GHC.Ptr (Ptr(..), plusPtr) + +import Control.Concurrent +import qualified Data.ByteString as ByteString +import Data.ByteString.Internal(toForeignPtr) +import Data.IORef(newIORef, readIORef, writeIORef) +import Foreign.ForeignPtr(withForeignPtr) +import Foreign.Marshal.Utils(copyBytes) + +import GHC.Compact + +-- | A serialized version of the 'Compact' metadata (each block with +-- address and size and the address of the root). This structure is +-- meant to be sent alongside the actual 'Compact' data. It can be +-- sent out of band in advance if the data is to be sent over RDMA +-- (which requires both sender and receiver to have pinned buffers). +data SerializedCompact a = SerializedCompact + { serializedCompactBlockList :: [(Ptr a, Word)] + , serializedCompactRoot :: Ptr a + } + +addrIsNull :: Addr# -> Bool +addrIsNull addr = isTrue# (nullAddr# `eqAddr#` addr) + +compactGetFirstBlock :: Compact# -> IO (Ptr a, Word) +compactGetFirstBlock buffer = + IO (\s -> case compactGetFirstBlock# buffer s of + (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) ) + +compactGetNextBlock :: Compact# -> Addr# -> IO (Ptr a, Word) +compactGetNextBlock buffer block = + IO (\s -> case compactGetNextBlock# buffer block s of + (# s', addr, size #) -> (# s', (Ptr addr, W# size) #) ) + +mkBlockList :: Compact# -> IO [(Ptr a, Word)] +mkBlockList buffer = compactGetFirstBlock buffer >>= go + where + go :: (Ptr a, Word) -> IO [(Ptr a, Word)] + go (Ptr block, _) | addrIsNull block = return [] + go item@(Ptr block, _) = do + next <- compactGetNextBlock buffer block + rest <- go next + return $ item : rest + +-- We MUST mark withSerializedCompact as NOINLINE +-- Otherwise the compiler will eliminate the call to touch# +-- causing the Compact# to be potentially GCed too eagerly, +-- before func had a chance to copy everything into its own +-- buffers/sockets/whatever + +-- | Serialize the 'Compact', and call the provided function with +-- with the 'Compact' serialized representation. It is not safe +-- to return the pointer from the action and use it after +-- the action completes: all uses must be inside this bracket, +-- since we cannot guarantee that the compact region will stay +-- live from the 'Ptr' object. For example, it would be +-- unsound to use 'unsafeInterleaveIO' to lazily construct +-- a lazy bytestring from the 'Ptr'. +-- +{-# NOINLINE withSerializedCompact #-} +withSerializedCompact :: Compact a -> + (SerializedCompact a -> IO c) -> IO c +withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do + rootPtr <- IO (\s -> case anyToAddr# root s of + (# s', rootAddr #) -> (# s', Ptr rootAddr #) ) + blockList <- mkBlockList buffer + let serialized = SerializedCompact blockList rootPtr + r <- func serialized + IO (\s -> case touch# buffer s of + s' -> (# s', r #) ) + +fixupPointers :: Addr# -> Addr# -> State# RealWorld -> + (# State# RealWorld, Maybe (Compact a) #) +fixupPointers firstBlock rootAddr s = + case compactFixupPointers# firstBlock rootAddr s of + (# s', buffer, adjustedRoot #) -> + if addrIsNull adjustedRoot then (# s', Nothing #) + else case addrToAny# adjustedRoot of + (# root #) -> case mkCompact buffer root s' of + (# s'', c #) -> (# s'', Just c #) + +-- | Deserialize a 'SerializedCompact' into a in-memory 'Compact'. The +-- provided function will be called with the address and size of each +-- newly allocated block in succession, and should fill the memory +-- from the external source (eg. by reading from a socket or from disk) +-- 'importCompact' can return Nothing if the 'Compact' was corrupt +-- or it had pointers that could not be adjusted. +importCompact :: SerializedCompact a -> (Ptr b -> Word -> IO ()) -> + IO (Maybe (Compact a)) + +-- what we would like is +{- + importCompactPtrs ((firstAddr, firstSize):rest) = do + (firstBlock, compact) <- compactAllocateAt firstAddr firstSize + #nullAddr + fillBlock firstBlock firstAddr firstSize + let go prev [] = return () + go prev ((addr, size):rest) = do + (block, _) <- compactAllocateAt addr size prev + fillBlock block addr size + go block rest + go firstBlock rest + if isTrue# (compactFixupPointers compact) then + return $ Just compact + else + return Nothing + +But we can't do that because IO Addr# is not valid (kind mismatch) +This check exists to prevent a polymorphic data constructor from using +an unlifted type (which would break GC) - it would not a problem for IO +because IO stores a function, not a value, but the kind check is there +anyway. +Note that by the reasoning, we cannot do IO (# Addr#, Word# #), nor +we can do IO (Addr#, Word#) (that would break the GC for real!) + +And therefore we need to do everything with State# explicitly. +-} + +-- just do shut up GHC +importCompact (SerializedCompact [] _) _ = return Nothing +importCompact (SerializedCompact blocks root) filler = do + -- I'm not sure why we need a bang pattern here, given that + -- these are obviously strict lets, but ghc complains otherwise + let !((_, W# firstSize):otherBlocks) = blocks + let !(Ptr rootAddr) = root + IO $ \s0 -> + case compactAllocateBlock# firstSize nullAddr# s0 of { + (# s1, firstBlock #) -> + case fillBlock firstBlock firstSize s1 of { s2 -> + case go firstBlock otherBlocks s2 of { s3 -> + fixupPointers firstBlock rootAddr s3 + }}} + where + -- note that the case statements above are strict even though + -- they don't seem to inspect their argument because State# + -- is an unlifted type + fillBlock :: Addr# -> Word# -> State# RealWorld -> State# RealWorld + fillBlock addr size s = case filler (Ptr addr) (W# size) of + IO action -> case action s of + (# s', _ #) -> s' + + go :: Addr# -> [(Ptr a, Word)] -> State# RealWorld -> State# RealWorld + go _ [] s = s + go previous ((_, W# size):rest) s = + case compactAllocateBlock# size previous s of + (# s', block #) -> case fillBlock block size s' of + s'' -> go block rest s'' + +sanityCheckByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> Bool +sanityCheckByteStrings (SerializedCompact scl _) bsl = go scl bsl + where + go [] [] = True + go (_:_) [] = False + go [] (_:_) = False + go ((_, size):scs) (bs:bss) = + fromIntegral size == ByteString.length bs && go scs bss + +-- | Convenience function for importing a compact region that is represented +-- by a list of strict 'ByteString's. +-- +importCompactByteStrings :: SerializedCompact a -> [ByteString.ByteString] -> + IO (Maybe (Compact a)) +importCompactByteStrings serialized stringList = + -- sanity check stringList first - if we throw an exception later we leak + -- memory! + if not (sanityCheckByteStrings serialized stringList) then + return Nothing + else do + state <- newIORef stringList + let filler :: Ptr Word8 -> Word -> IO () + filler to size = do + -- this pattern match will never fail + (next:rest) <- readIORef state + let (fp, off, _) = toForeignPtr next + withForeignPtr fp $ \from -> do + copyBytes to (from `plusPtr` off) (fromIntegral size) + writeIORef state rest + importCompact serialized filler diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,41 @@ +This library (compact) is derived from code from the GHC project which +is largely (c) The University of Glasgow, and distributable under a +BSD-style license (see below). +Portions of this library were written by Giovanni Campagna +(gcampagn@cs.stanford.edu). They are available under the same license. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2001-2014, The University Court of the University of Glasgow. +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 name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/ghc-compact.cabal b/ghc-compact.cabal new file mode 100644 --- /dev/null +++ b/ghc-compact.cabal @@ -0,0 +1,47 @@ +name: ghc-compact +version: 0.1.0.0 +-- NOTE: Don't forget to update ./changelog.md +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/ghc-compact +synopsis: In memory storage of deeply evaluated data structure +category: Data +description: + This package provides minimal functionality 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). + . + Internally, the struct is stored a single contiguous block of memory, + which allows efficient serialization and deserialization of structs + for distributed computing. + . + This package provides a low-level API; see also the which provides a user-facing API. +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==8.2.1 + +source-repository head + type: git + location: http://git.haskell.org/ghc.git + subdir: libraries/ghc-compact + +library + default-language: Haskell2010 + other-extensions: + MagicHash + BangPatterns + UnboxedTuples + CPP + + build-depends: ghc-prim == 0.5.1.0, + base >= 4.9.0 && < 4.11, + bytestring >= 0.10.6.0 && < 0.11 + ghc-options: -Wall + + exposed-modules: GHC.Compact + GHC.Compact.Serialized