{-# 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 <gcampagn@cs.stanford.edu> 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. <http://ezyang.com/compact.html>
--
-- 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 fully evaluating the data + copying it. However,
-- because '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 '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 'Control.Exception.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 :: forall a.
Compact#
-> a -> State# RealWorld -> (# State# RealWorld, Compact a #)
mkCompact Compact#
compact# a
a State# RealWorld
s =
  case IO (MVar ()) -> State# RealWorld -> (# State# RealWorld, MVar () #)
forall {a}. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (() -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()) State# RealWorld
s of { (# State# RealWorld
s1, MVar ()
lock #) ->
  (# State# RealWorld
s1, Compact# -> a -> MVar () -> Compact a
forall a. Compact# -> a -> MVar () -> Compact a
Compact Compact#
compact# a
a MVar ()
lock #) }
 where
  unIO :: IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (IO State# RealWorld -> (# State# RealWorld, a #)
a) = State# RealWorld -> (# State# RealWorld, a #)
a

-- | Transfer @a@ into a new compact region, with a preallocated size (in
-- bytes), 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 -- ^ Size of the compact region, in bytes
    -> Bool -- ^ Whether to retain internal sharing
    -> a
    -> IO (Compact a)
compactSized :: forall a. Int -> Bool -> a -> IO (Compact a)
compactSized (I# Int#
size) Bool
share a
a = (State# RealWorld -> (# State# RealWorld, Compact a #))
-> IO (Compact a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Compact a #))
 -> IO (Compact a))
-> (State# RealWorld -> (# State# RealWorld, Compact a #))
-> IO (Compact a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
  case Word# -> State# RealWorld -> (# State# RealWorld, Compact# #)
compactNew# (Int# -> Word#
int2Word# Int#
size) State# RealWorld
s0 of { (# State# RealWorld
s1, Compact#
compact# #) ->
  case Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
forall {a}.
Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
compactAddPrim Compact#
compact# a
a State# RealWorld
s1 of { (# State# RealWorld
s2, a
pk #) ->
  Compact#
-> a -> State# RealWorld -> (# State# RealWorld, Compact a #)
forall a.
Compact#
-> a -> State# RealWorld -> (# State# RealWorld, Compact a #)
mkCompact Compact#
compact# a
pk State# RealWorld
s2 }}
 where
  compactAddPrim :: Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
compactAddPrim
    | Bool
share = Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
forall {a}.
Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
compactAddWithSharing#
    | Bool
otherwise = Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
forall {a}.
Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
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 :: forall a. Compact a -> a
getCompact (Compact Compact#
_ a
obj MVar ()
_) = a
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 :: forall a. a -> IO (Compact a)
compact = Int -> Bool -> a -> IO (Compact a)
forall a. Int -> Bool -> a -> IO (Compact a)
compactSized Int
31268 Bool
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 :: forall a. a -> IO (Compact a)
compactWithSharing = Int -> Bool -> a -> IO (Compact a)
forall a. Int -> Bool -> a -> IO (Compact a)
compactSized Int
31268 Bool
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 :: forall b a. Compact b -> a -> IO (Compact a)
compactAdd (Compact Compact#
compact# b
_ MVar ()
lock) a
a = MVar () -> (() -> IO (Compact a)) -> IO (Compact a)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO (Compact a)) -> IO (Compact a))
-> (() -> IO (Compact a)) -> IO (Compact a)
forall a b. (a -> b) -> a -> b
$ \()
_ -> (State# RealWorld -> (# State# RealWorld, Compact a #))
-> IO (Compact a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Compact a #))
 -> IO (Compact a))
-> (State# RealWorld -> (# State# RealWorld, Compact a #))
-> IO (Compact a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
forall {a}.
Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
compactAdd# Compact#
compact# a
a State# RealWorld
s of { (# State# RealWorld
s1, a
pk #) ->
  (# State# RealWorld
s1, Compact# -> a -> MVar () -> Compact a
forall a. Compact# -> a -> MVar () -> Compact a
Compact Compact#
compact# a
pk MVar ()
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 :: forall b a. Compact b -> a -> IO (Compact a)
compactAddWithSharing (Compact Compact#
compact# b
_ MVar ()
lock) a
a =
  MVar () -> (() -> IO (Compact a)) -> IO (Compact a)
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO (Compact a)) -> IO (Compact a))
-> (() -> IO (Compact a)) -> IO (Compact a)
forall a b. (a -> b) -> a -> b
$ \()
_ -> (State# RealWorld -> (# State# RealWorld, Compact a #))
-> IO (Compact a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Compact a #))
 -> IO (Compact a))
-> (State# RealWorld -> (# State# RealWorld, Compact a #))
-> IO (Compact a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
forall {a}.
Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)
compactAddWithSharing# Compact#
compact# a
a State# RealWorld
s of { (# State# RealWorld
s1, a
pk #) ->
    (# State# RealWorld
s1, Compact# -> a -> MVar () -> Compact a
forall a. Compact# -> a -> MVar () -> Compact a
Compact Compact#
compact# a
pk MVar ()
lock #) }

-- | Check if the second argument is inside the passed 'Compact'.
--
inCompact :: Compact b -> a -> IO Bool
inCompact :: forall b a. Compact b -> a -> IO Bool
inCompact (Compact Compact#
buffer b
_ MVar ()
_) !a
val =
  (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> case Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)
forall a.
Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)
compactContains# Compact#
buffer a
val State# RealWorld
s of
         (# State# RealWorld
s', Int#
v #) -> (# State# RealWorld
s', Int# -> Bool
isTrue# Int#
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 :: forall a. a -> IO Bool
isCompact !a
val =
  (State# RealWorld -> (# State# RealWorld, Bool #)) -> IO Bool
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> case a -> State# RealWorld -> (# State# RealWorld, Int# #)
forall a. a -> State# RealWorld -> (# State# RealWorld, Int# #)
compactContainsAny# a
val State# RealWorld
s of
         (# State# RealWorld
s', Int#
v #) -> (# State# RealWorld
s', Int# -> Bool
isTrue# Int#
v #) )

-- | Returns the size in bytes of the compact region.
--
compactSize :: Compact a -> IO Word
compactSize :: forall a. Compact a -> IO Word
compactSize (Compact Compact#
buffer a
_ MVar ()
lock) = MVar () -> (() -> IO Word) -> IO Word
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO Word) -> IO Word) -> (() -> IO Word) -> IO Word
forall a b. (a -> b) -> a -> b
$ \()
_ -> (State# RealWorld -> (# State# RealWorld, Word #)) -> IO Word
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Word #)) -> IO Word)
-> (State# RealWorld -> (# State# RealWorld, Word #)) -> IO Word
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
   case Compact# -> State# RealWorld -> (# State# RealWorld, Word# #)
compactSize# Compact#
buffer State# RealWorld
s0 of (# State# RealWorld
s1, Word#
sz #) -> (# State# RealWorld
s1, Word# -> Word
W# Word#
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 :: forall a. Compact a -> Word -> IO ()
compactResize (Compact Compact#
oldBuffer a
_ MVar ()
lock) (W# Word#
new_size) =
  MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case Compact# -> Word# -> State# RealWorld -> State# RealWorld
compactResize# Compact#
oldBuffer Word#
new_size State# RealWorld
s of
      State# RealWorld
s' -> (# State# RealWorld
s', () #)