Overhaul of Compact Regions (#12455)

Summary:
This commit makes various improvements and addresses some issues with
Compact Regions (aka Compact Normal Forms).

This was the most important thing I wanted to fix.  Compaction
previously prevented GC from running until it was complete, which
would be a problem in a multicore setting.  Now, we compact using a
hand-written Cmm routine that can be interrupted at any point.  When a
GC is triggered during a sharing-enabled compaction, the GC has to
traverse and update the hash table, so this hash table is now stored
in the StgCompactNFData object.

Previously, compaction consisted of a deepseq using the NFData class,
followed by a traversal in C code to copy the data.  This is now done
in a single pass with hand-written Cmm (see rts/Compact.cmm). We no
longer use the NFData instances, instead the Cmm routine evaluates
components directly as it compacts.

The new compaction is about 50% faster than the old one with no
sharing, and a little faster on average with sharing (the cost of the
hash table dominates when we're doing sharing).

Static objects that don't (transitively) refer to any CAFs don't need
to be copied into the compact region.  In particular this means we
often avoid copying Char values and small Int values, because these
are static closures in the runtime.

Each Compact# object can support a single compactAdd# operation at any
given time, so the Data.Compact library now enforces mutual exclusion
using an MVar stored in the Compact object.

We now get exceptions rather than killing everything with a barf()
when we encounter an object that cannot be compacted (a function, or a
mutable object).  We now also detect pinned objects, which can't be
compacted either.

The Data.Compact API has been refactored and cleaned up.  A new
compactSize operation returns the size (in bytes) of the compact
object.

Most of the documentation is in the Haddock docs for the compact
library, which I've expanded and improved here.

Various comments in the code have been improved, especially the main
Note [Compact Normal Forms] in rts/sm/CNF.c.

I've added a few tests, and expanded a few of the tests that were
there.  We now also run the tests with GHCi, and in a new test way
that enables sanity checking (+RTS -DS).

There's a benchmark in libraries/compact/tests/compact_bench.hs for
measuring compaction speed and comparing sharing vs. no sharing.

The field totalDataW in StgCompactNFData was unnecessary.

Test Plan:
* new unit tests
* validate
* tested manually that we can compact Data.Aeson data

Reviewers: gcampax, bgamari, ezyang, austin, niteria, hvr, erikd

Subscribers: thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D2751

GHC Trac Issues: #12455

34 files changed, 473 insertions, 163 deletions

diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index a6c1083834..88938e2ee2 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/Control/Exception.hs
@@ -49,6 +49,7 @@ module Control.Exception (
         BlockedIndefinitelyOnMVar(..),
         BlockedIndefinitelyOnSTM(..),
         AllocationLimitExceeded(..),
+        CompactionFailed(..),
         Deadlock(..),
         NoMethodError(..),
         PatternMatchFail(..),
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index 9dd96488bc..3e7ac0f9e8 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -32,6 +32,7 @@ module Control.Exception.Base (
         BlockedIndefinitelyOnMVar(..),
         BlockedIndefinitelyOnSTM(..),
         AllocationLimitExceeded(..),
+        CompactionFailed(..),
         Deadlock(..),
         NoMethodError(..),
         PatternMatchFail(..),
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 69d2c330c9..a8d63d3b28 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -24,6 +24,8 @@ module GHC.IO.Exception (
   Deadlock(..),
   AllocationLimitExceeded(..), allocationLimitExceeded,
   AssertionFailed(..),
+  CompactionFailed(..),
+  cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,
 
   SomeAsyncException(..),
   asyncExceptionToException, asyncExceptionFromException,
@@ -127,6 +129,35 @@ allocationLimitExceeded = toException AllocationLimitExceeded
 
 -----
 
+-- |Compaction found an object that cannot be compacted.  Functions
+-- cannot be compacted, nor can mutable objects or pinned objects.
+-- See 'Data.Compact.compact'.
+--
+-- @since 4.10.0.0
+data CompactionFailed = CompactionFailed String
+
+-- | @since 4.10.0.0
+instance Exception CompactionFailed where
+
+-- | @since 4.10.0.0
+instance Show CompactionFailed where
+    showsPrec _ (CompactionFailed why) =
+      showString ("compaction failed: " ++ why)
+
+cannotCompactFunction :: SomeException -- for the RTS
+cannotCompactFunction =
+  toException (CompactionFailed "cannot compact functions")
+
+cannotCompactPinned :: SomeException -- for the RTS
+cannotCompactPinned =
+  toException (CompactionFailed "cannot compact pinned objects")
+
+cannotCompactMutable :: SomeException -- for the RTS
+cannotCompactMutable =
+  toException (CompactionFailed "cannot compact mutable objects")
+
+-----
+
 -- |'assert' was applied to 'False'.
 newtype AssertionFailed = AssertionFailed String
 
diff --git a/libraries/compact/Data/Compact.hs b/libraries/compact/Data/Compact.hs
index 7cedd1c27a..85d1b623b4 100644
--- a/libraries/compact/Data/Compact.hs
+++ b/libraries/compact/Data/Compact.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-name-shadowing #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -18,72 +19,102 @@
 -- holding fully evaluated data in a consecutive block of memory.
 --
 -- /Since: 1.0.0/
+
 module Data.Compact (
+  -- * The Compact type
   Compact,
+
+  -- * Compacting data
+  compact,
+  compactWithSharing,
+  compactAdd,
+  compactAddWithSharing,
+
+  -- * Inspecting a Compact
   getCompact,
   inCompact,
   isCompact,
+  compactSize,
 
-  newCompact,
-  newCompactNoShare,
-  appendCompact,
-  appendCompactNoShare,
+  -- * Other utilities
+  compactResize,
   ) where
 
--- Write down all GHC.Prim deps explicitly to keep them at minimum
-import GHC.Prim (Compact#,
-                 compactNew#,
-                 State#,
-                 RealWorld,
-                 Int#,
-                 )
--- We need to import Word from GHC.Types to see the representation
--- and to able to access the Word# to pass down the primops
-import GHC.Types (IO(..), Word(..))
-
-import Control.DeepSeq (NFData, force)
-
-import Data.Compact.Internal(Compact(..),
-                             isCompact,
-                             inCompact,
-                             compactAppendEvaledInternal)
-
--- |Retrieve the object that was stored in a Compact
+import Control.Concurrent
+import Control.DeepSeq (NFData)
+import GHC.Prim
+import GHC.Types
+
+import Data.Compact.Internal as Internal
+
+-- | Retrieve the object that was stored in a 'Compact'
 getCompact :: Compact a -> a
-getCompact (Compact _ obj) = obj
-
-compactAppendInternal :: NFData a => Compact# -> a -> Int# ->
-                         State# RealWorld -> (# State# RealWorld, Compact a #)
-compactAppendInternal buffer root share s =
-  case force root of
-    !eval -> compactAppendEvaledInternal buffer eval share s
-
-compactAppendInternalIO :: NFData a => Int# -> Compact b -> a -> IO (Compact a)
-compactAppendInternalIO share (Compact buffer _) root =
-  IO (\s -> compactAppendInternal buffer root share s)
-
--- |Append a value to a 'Compact', and return a new 'Compact'
--- that shares the same buffer but a different root object.
-appendCompact :: NFData a => Compact b -> a -> IO (Compact a)
-appendCompact = compactAppendInternalIO 1#
-
--- |Append a value to a 'Compact'. This function differs from
--- 'appendCompact' in that it will not preserve internal sharing
--- in the passed in value (and it will diverge on cyclic structures).
-appendCompactNoShare :: NFData a => Compact b -> a -> IO (Compact a)
-appendCompactNoShare = compactAppendInternalIO 0#
-
-compactNewInternal :: NFData a => Int# -> Word -> a -> IO (Compact a)
-compactNewInternal share (W# size) root =
-  IO (\s -> case compactNew# size s of
-         (# s', buffer #) -> compactAppendInternal buffer root share s' )
-
--- |Create a new 'Compact', with the provided value as suggested block
--- size (which will be adjusted if unsuitable), and append the given
--- value to it, as if calling 'appendCompact'
-newCompact :: NFData a => Word -> a -> IO (Compact a)
-newCompact = compactNewInternal 1#
-
--- |Create a new 'Compact', but append the value using 'appendCompactNoShare'
-newCompactNoShare :: NFData a => Word -> a -> IO (Compact a)
-newCompactNoShare = compactNewInternal 0#
+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.  Loops if the
+-- structure constains cycles.
+--
+-- The NFData constraint is just to ensure that the object contains no
+-- functions, 'compact' does not actually use it.  If your object
+-- contains any functions, then 'compact' will fail. (and your
+-- 'NFData' instance is lying).
+--
+compact :: NFData a => a -> IO (Compact a)
+compact = Internal.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 'NFData' constraint is just to ensure that the object contains no
+-- functions, `compact` does not actually use it.  If your object
+-- contains any functions, then 'compactWithSharing' will fail. (and
+-- your 'NFData' instance is lying).
+--
+compactWithSharing :: NFData a => a -> IO (Compact a)
+compactWithSharing = Internal.compactSized 31268 True
+
+-- | Add a value to an existing 'Compact'.  Behaves exactly like
+-- 'compact' with respect to sharing and the 'NFData' constraint.
+compactAdd :: NFData a => 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'.  Behaves exactly like
+-- 'compactWithSharing' with respect to sharing and the 'NFData'
+-- constraint.
+compactAddWithSharing :: NFData a => 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 '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'
+isCompact :: a -> IO Bool
+isCompact !val =
+  IO (\s -> case compactContainsAny# val s of
+         (# s', v #) -> (# s', isTrue# v #) )
+
+compactSize :: Compact a -> IO Word
+compactSize (Compact buffer _ lock) = withMVar lock $ \_ -> IO $ \s0 ->
+   case compactSize# buffer s0 of (# s1, sz #) -> (# s1, W# sz #)
+
+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/libraries/compact/Data/Compact/Internal.hs b/libraries/compact/Data/Compact/Internal.hs
index 36cd438b1e..2780d19b1a 100644
--- a/libraries/compact/Data/Compact/Internal.hs
+++ b/libraries/compact/Data/Compact/Internal.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
 
@@ -22,57 +21,82 @@
 --
 -- /Since: 1.0.0/
 
-module Data.Compact.Internal(
-  Compact(..),
-  compactResize,
-  isCompact,
-  inCompact,
+module Data.Compact.Internal
+  ( Compact(..)
+  , mkCompact
+  , compactSized
+  ) where
 
-  compactAppendEvaledInternal,
-) where
+import Control.Concurrent.MVar
+import Control.DeepSeq
+import GHC.Prim
+import GHC.Types
 
--- Write down all GHC.Prim deps explicitly to keep them at minimum
-import GHC.Prim (Compact#,
-                 compactAppend#,
-                 compactResize#,
-                 compactContains#,
-                 compactContainsAny#,
-                 State#,
-                 RealWorld,
-                 Int#,
-                 )
--- We need to import Word from GHC.Types to see the representation
--- and to able to access the Word# to pass down the primops
-import GHC.Types (IO(..), Word(..), isTrue#)
-
--- | A 'Compact' contains fully evaluated, pure, and immutable data. If
--- any object in the compact is alive, then the whole compact is
--- alive. This means that 'Compact's are very cheap to keep around,
--- because the data inside a compact does not need to be traversed by
--- the garbage collector. However, the tradeoff is that the memory
--- that contains a 'Compact' cannot be recovered until the whole 'Compact'
--- is garbage.
-data Compact a = Compact Compact# a
-
--- |Check if the second argument is inside the 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
-isCompact :: a -> IO Bool
-isCompact !val =
-  IO (\s -> case compactContainsAny# val s of
-         (# s', v #) -> (# s', isTrue# v #) )
+-- | 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 perfomed only once.  However, retainining internal
+-- sharing during the compaction process is very costly, so it is
+-- optional; there are two ways to create a 'Compact': 'compact' and
+-- 'compactWithSharing'.
+--
+-- Data can be added to an existing 'Compact' with 'compactAdd' or
+-- 'compactAddWithSharing'.
+--
+-- 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'.
+--
+-- * Mutable objects 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'
 
-compactResize :: Compact a -> Word -> IO ()
-compactResize (Compact oldBuffer _) (W# new_size) =
-  IO (\s -> case compactResize# oldBuffer new_size s of
-         s' -> (# s', () #) )
+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
 
-compactAppendEvaledInternal :: Compact# -> a -> Int# -> State# RealWorld ->
-                               (# State# RealWorld, Compact a #)
-compactAppendEvaledInternal buffer root share s =
-  case compactAppend# buffer root share s of
-    (# s', adjustedRoot #) -> (# s', Compact buffer adjustedRoot #)
+compactSized :: NFData a => 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#
diff --git a/libraries/compact/Data/Compact/Serialized.hs b/libraries/compact/Data/Compact/Serialized.hs
index e58f9eef83..bdc2aff733 100644
--- a/libraries/compact/Data/Compact/Serialized.hs
+++ b/libraries/compact/Data/Compact/Serialized.hs
@@ -29,30 +29,13 @@ module Data.Compact.Serialized(
   importCompactByteStrings,
 ) where
 
--- Write down all GHC.Prim deps explicitly to keep them at minimum
-import GHC.Prim (Compact#,
-                 compactGetFirstBlock#,
-                 compactGetNextBlock#,
-                 compactAllocateBlock#,
-                 compactFixupPointers#,
-                 touch#,
-                 Addr#,
-                 nullAddr#,
-                 eqAddr#,
-                 addrToAny#,
-                 anyToAddr#,
-                 State#,
-                 RealWorld,
-                 Word#,
-                 )
-
--- We need to import Word from GHC.Types to see the representation
--- and to able to access the Word# to pass down the primops
-import GHC.Types (IO(..), Word(..), isTrue#)
+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)
@@ -60,16 +43,16 @@ import Foreign.ForeignPtr(withForeignPtr)
 import Foreign.Marshal.Utils(copyBytes)
 import Control.DeepSeq(NFData, force)
 
-import Data.Compact.Internal(Compact(..))
+import Data.Compact.Internal
 
 -- |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
+data SerializedCompact a = SerializedCompact
+  { serializedCompactBlockList :: [(Ptr a, Word)]
+  , serializedCompactRoot :: Ptr a
   }
 
 addrIsNull :: Addr# -> Bool
@@ -109,7 +92,7 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go
 {-# NOINLINE withSerializedCompact #-}
 withSerializedCompact :: NFData c => Compact a ->
                          (SerializedCompact a -> IO c) -> IO c
-withSerializedCompact (Compact buffer root) func = do
+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
@@ -129,7 +112,8 @@ fixupPointers firstBlock rootAddr s =
     (# s', buffer, adjustedRoot #) ->
       if addrIsNull adjustedRoot then (# s', Nothing #)
       else case addrToAny# adjustedRoot of
-        (# root #) -> (# s', Just $ Compact buffer root #)
+        (# 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
@@ -175,11 +159,13 @@ importCompact (SerializedCompact blocks root) filler = do
   -- 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 )
+  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#
diff --git a/libraries/compact/tests/.gitignore b/libraries/compact/tests/.gitignore
index c20cf7d4be..8887a1bbea 100644
--- a/libraries/compact/tests/.gitignore
+++ b/libraries/compact/tests/.gitignore
@@ -1,6 +1,3 @@
-*.stderr
-!compact_serialize.stderr
-*.stdout
 .hpc.*
 *.eventlog
 *.genscript
diff --git a/libraries/compact/tests/all.T b/libraries/compact/tests/all.T
index fd543142e9..bdcf522cf6 100644
--- a/libraries/compact/tests/all.T
+++ b/libraries/compact/tests/all.T
@@ -1,6 +1,19 @@
-test('compact_simple', omit_ways(['ghci']), compile_and_run, [''])
-test('compact_loop', omit_ways(['ghci']), compile_and_run, [''])
-test('compact_append', omit_ways(['ghci']), compile_and_run, [''])
-test('compact_autoexpand', omit_ways(['ghci']), compile_and_run, [''])
-test('compact_simple_array', omit_ways(['ghci']), compile_and_run, [''])
-test('compact_serialize', omit_ways(['ghci']), compile_and_run, [''])
\ No newline at end of file
+setTestOpts(extra_ways(['sanity']))
+
+test('compact_simple', normal, compile_and_run, [''])
+test('compact_loop', normal, compile_and_run, [''])
+test('compact_append', normal, compile_and_run, [''])
+test('compact_autoexpand', normal, compile_and_run, [''])
+test('compact_simple_array', normal, compile_and_run, [''])
+test('compact_huge_array', normal, compile_and_run, [''])
+test('compact_serialize', normal, compile_and_run, [''])
+test('compact_largemap', normal, compile_and_run, [''])
+test('compact_threads', [ extra_run_opts('1000') ], compile_and_run, [''])
+test('compact_cycle', extra_run_opts('+RTS -K1m'), compile_and_run, [''])
+test('compact_function', exit_code(1), compile_and_run, [''])
+test('compact_mutable', exit_code(1), compile_and_run, [''])
+test('compact_pinned', exit_code(1), compile_and_run, [''])
+test('compact_gc', normal, compile_and_run, [''])
+test('compact_share', normal, compile_and_run, [''])
+test('compact_bench', [ ignore_stdout, extra_run_opts('100') ],
+                       compile_and_run, [''])
diff --git a/libraries/compact/tests/compact_append.hs b/libraries/compact/tests/compact_append.hs
index 59f86777b7..e61262eea6 100644
--- a/libraries/compact/tests/compact_append.hs
+++ b/libraries/compact/tests/compact_append.hs
@@ -16,10 +16,10 @@ assertEquals expected actual =
 
 main = do
   let val = ("hello", Just 42) :: (String, Maybe Int)
-  str <- newCompact 4096 val
+  str <- compactWithSharing val
 
   let val2 = ("world", 42) :: (String, Int)
-  str2 <- appendCompact str val2
+  str2 <- compactAddWithSharing str val2
 
   -- check that values where not corrupted
   assertEquals ("hello", Just 42) val
diff --git a/libraries/compact/tests/compact_autoexpand.hs b/libraries/compact/tests/compact_autoexpand.hs
index 5db0bbc55f..5134380777 100644
--- a/libraries/compact/tests/compact_autoexpand.hs
+++ b/libraries/compact/tests/compact_autoexpand.hs
@@ -4,6 +4,7 @@ import Control.Exception
 import System.Mem
 
 import Data.Compact
+import Data.Compact.Internal
 
 assertFail :: String -> IO ()
 assertFail msg = throwIO $ AssertionFailed msg
@@ -21,7 +22,7 @@ main = do
   -- so total 3072 words, 12288 bytes on x86, 24576 on x86_64
   -- it should not fit in one block
   let val = replicate 4096 7 :: [Int]
-  str <- newCompact 1 val
+  str <- compactSized 1 True val
   assertEquals val (getCompact str)
   performMajorGC
   assertEquals val (getCompact str)
diff --git a/libraries/compact/tests/compact_bench.hs b/libraries/compact/tests/compact_bench.hs
new file mode 100644
index 0000000000..3764c3e3e1
--- /dev/null
+++ b/libraries/compact/tests/compact_bench.hs
@@ -0,0 +1,28 @@
+import Control.Exception
+import Data.Compact
+import Data.Compact.Internal
+import qualified Data.Map as Map
+import Data.Time.Clock
+import Text.Printf
+import System.Environment
+import System.Mem
+import Control.DeepSeq
+
+-- Benchmark compact against compactWithSharing. e.g.
+--   ./compact_bench 1000000
+
+main = do
+  [n] <- map read <$> getArgs
+  let m = Map.fromList [(x,[x*1000..x*1000+10]) | x <- [1..(n::Integer)]]
+  evaluate (force m)
+  timeIt "compact" $ compact m >>= compactSize >>= print
+  timeIt "compactWithSharing" $ compactWithSharing m >>= compactSize >>= print
+
+timeIt :: String -> IO a -> IO a
+timeIt str io = do
+  performMajorGC
+  t0 <- getCurrentTime
+  a <- io
+  t1 <- getCurrentTime
+  printf "%s: %.2f\n" str (realToFrac (t1 `diffUTCTime` t0) :: Double)
+  return a
diff --git a/libraries/compact/tests/compact_bytestring.hs b/libraries/compact/tests/compact_bytestring.hs
new file mode 100644
index 0000000000..16c486ba58
--- /dev/null
+++ b/libraries/compact/tests/compact_bytestring.hs
@@ -0,0 +1,8 @@
+import qualified Data.ByteString.Char8 as B
+import Data.Compact
+import Data.Compact.Internal
+import qualified Data.Map as Map
+
+main = do
+  c <- compact (Map.fromList [(B.pack (show x), x) | x <- [1..(10000::Int)]])
+  print (getCompact c)
diff --git a/libraries/compact/tests/compact_cycle.hs b/libraries/compact/tests/compact_cycle.hs
new file mode 100644
index 0000000000..4c771a1d34
--- /dev/null
+++ b/libraries/compact/tests/compact_cycle.hs
@@ -0,0 +1,10 @@
+import Control.Exception
+import Data.Compact
+import Data.Compact.Internal
+import qualified Data.Map as Map
+import System.Exit
+
+main = do
+  c <- compactWithSharing (cycle "abc") -- magic!
+  print (length (show (take 100 (getCompact c))))
+  print =<< compactSize c
diff --git a/libraries/compact/tests/compact_cycle.stdout b/libraries/compact/tests/compact_cycle.stdout
new file mode 100644
index 0000000000..6fc8a53046
--- /dev/null
+++ b/libraries/compact/tests/compact_cycle.stdout
@@ -0,0 +1,2 @@
+102
+32768
diff --git a/libraries/compact/tests/compact_function.hs b/libraries/compact/tests/compact_function.hs
new file mode 100644
index 0000000000..fc4f4ca172
--- /dev/null
+++ b/libraries/compact/tests/compact_function.hs
@@ -0,0 +1,10 @@
+import Control.DeepSeq
+import Control.Exception
+import Data.Compact
+
+data HiddenFunction = HiddenFunction (Int -> Int)
+
+instance NFData HiddenFunction where
+  rnf x = x `seq` () -- ignore the function inside
+
+main = compact (HiddenFunction (+1))
diff --git a/libraries/compact/tests/compact_function.stderr b/libraries/compact/tests/compact_function.stderr
new file mode 100644
index 0000000000..197da0460b
--- /dev/null
+++ b/libraries/compact/tests/compact_function.stderr
@@ -0,0 +1 @@
+compact_function: compaction failed: cannot compact functions
diff --git a/libraries/compact/tests/compact_gc.hs b/libraries/compact/tests/compact_gc.hs
new file mode 100644
index 0000000000..a88e87d958
--- /dev/null
+++ b/libraries/compact/tests/compact_gc.hs
@@ -0,0 +1,12 @@
+import Control.Monad
+import Data.Compact
+import Data.Compact.Internal
+import qualified Data.Map as Map
+
+main = do
+  let m = Map.fromList [(x,show x) | x <- [1..(10000::Int)]]
+  c <- compactWithSharing m
+  print =<< compactSize c
+  c <- foldM (\c _ -> do c <- compactWithSharing (getCompact c); print =<< compactSize c; return c) c [1..10]
+  print (length (show (getCompact c)))
+  print =<< compactSize c
diff --git a/libraries/compact/tests/compact_gc.stdout b/libraries/compact/tests/compact_gc.stdout
new file mode 100644
index 0000000000..c44d58836d
--- /dev/null
+++ b/libraries/compact/tests/compact_gc.stdout
@@ -0,0 +1,13 @@
+2228224
+2228224
+2228224
+2228224
+2228224
+2228224
+2228224
+2228224
+2228224
+2228224
+2228224
+137798
+2228224
diff --git a/libraries/compact/tests/compact_huge_array.hs b/libraries/compact/tests/compact_huge_array.hs
new file mode 100644
index 0000000000..8a8374297b
--- /dev/null
+++ b/libraries/compact/tests/compact_huge_array.hs
@@ -0,0 +1,61 @@
+module Main where
+
+import Control.Exception
+import Control.Monad
+import System.Mem
+
+import Control.Monad.ST
+import Data.Array
+import Data.Array.ST
+import qualified Data.Array.Unboxed as U
+import Control.DeepSeq
+
+import Data.Compact
+import Data.Compact.Internal
+
+assertFail :: String -> IO ()
+assertFail msg = throwIO $ AssertionFailed msg
+
+assertEquals :: (Eq a, Show a) => a -> a -> IO ()
+assertEquals expected actual =
+  if expected == actual then return ()
+  else assertFail $ "expected " ++ (show expected)
+       ++ ", got " ++ (show actual)
+
+arrTest :: (Monad m, MArray a e m, Num e) => m (a Int e)
+arrTest = do
+  arr <- newArray (1, 10) 0
+  forM_ [1..10] $ \j -> do
+    writeArray arr j (fromIntegral $ 2*j + 1)
+  return arr
+
+instance NFData (U.UArray i e) where
+  rnf x = seq x ()
+
+-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO ()
+test func = do
+  let fromList :: Array Int Int
+      fromList = listArray (1, 300000) [1..]
+      frozen :: Array Int Int
+      frozen = runST $ do
+        arr <- arrTest :: ST s (STArray s Int Int)
+        freeze arr
+      stFrozen :: Array Int Int
+      stFrozen = runSTArray arrTest
+      unboxedFrozen :: U.UArray Int Int
+      unboxedFrozen = runSTUArray arrTest
+
+  let val = (fromList, frozen, stFrozen, unboxedFrozen)
+  str <- func val
+
+  -- check that val is still good
+  assertEquals (fromList, frozen, stFrozen, unboxedFrozen) val
+  -- check the value in the compact
+  assertEquals val (getCompact str)
+  performMajorGC
+  -- check again the value in the compact
+  assertEquals val (getCompact str)
+
+main = do
+  test (compactSized 4096 True)
+  test (compactSized 4096 False)
diff --git a/libraries/compact/tests/compact_largemap.hs b/libraries/compact/tests/compact_largemap.hs
new file mode 100644
index 0000000000..0c72a32c75
--- /dev/null
+++ b/libraries/compact/tests/compact_largemap.hs
@@ -0,0 +1,10 @@
+import Data.Compact
+import Data.Compact.Internal
+import qualified Data.Map as Map
+
+main = do
+  let m = Map.fromList [(x,show x) | x <- [1..(10000::Integer)]]
+  c <- compactWithSharing m
+  print (length (show (getCompact c)))
+  c <- compact m
+  print (length (show (getCompact c)))
diff --git a/libraries/compact/tests/compact_largemap.stdout b/libraries/compact/tests/compact_largemap.stdout
new file mode 100644
index 0000000000..4825984a93
--- /dev/null
+++ b/libraries/compact/tests/compact_largemap.stdout
@@ -0,0 +1,2 @@
+137798
+137798
diff --git a/libraries/compact/tests/compact_loop.hs b/libraries/compact/tests/compact_loop.hs
index 0111fc1bdb..c8991b05d0 100644
--- a/libraries/compact/tests/compact_loop.hs
+++ b/libraries/compact/tests/compact_loop.hs
@@ -6,6 +6,7 @@ import System.Mem
 import Text.Show
 
 import Data.Compact
+import Data.Compact.Internal
 
 assertFail :: String -> IO ()
 assertFail msg = throwIO $ AssertionFailed msg
@@ -36,7 +37,7 @@ instance NFData Tree where
 test x = do
   let a = Node Nil x b
       b = Node a Nil Nil
-  str <- newCompact 4096 a
+  str <- compactSized 4096 True a
 
   -- check the value in the compact
   assertEquals a (getCompact str)
diff --git a/libraries/compact/tests/compact_mutable.hs b/libraries/compact/tests/compact_mutable.hs
new file mode 100644
index 0000000000..2d1a7f2572
--- /dev/null
+++ b/libraries/compact/tests/compact_mutable.hs
@@ -0,0 +1,13 @@
+import Control.Concurrent
+import Control.DeepSeq
+import Control.Exception
+import Data.Compact
+
+data HiddenMVar = HiddenMVar (MVar ())
+
+instance NFData HiddenMVar where
+  rnf x = x `seq` () -- ignore the function inside
+
+main = do
+  m <- newEmptyMVar
+  compact (HiddenMVar m)
diff --git a/libraries/compact/tests/compact_mutable.stderr b/libraries/compact/tests/compact_mutable.stderr
new file mode 100644
index 0000000000..9a4bd2892e
--- /dev/null
+++ b/libraries/compact/tests/compact_mutable.stderr
@@ -0,0 +1 @@
+compact_mutable: compaction failed: cannot compact mutable objects
diff --git a/libraries/compact/tests/compact_pinned.hs b/libraries/compact/tests/compact_pinned.hs
new file mode 100644
index 0000000000..a2a45bb7b9
--- /dev/null
+++ b/libraries/compact/tests/compact_pinned.hs
@@ -0,0 +1,6 @@
+import Control.DeepSeq
+import Control.Exception
+import qualified Data.ByteString.Char8 as B
+import Data.Compact
+
+main = compact (B.pack "abc")
diff --git a/libraries/compact/tests/compact_pinned.stderr b/libraries/compact/tests/compact_pinned.stderr
new file mode 100644
index 0000000000..1f470a0d49
--- /dev/null
+++ b/libraries/compact/tests/compact_pinned.stderr
@@ -0,0 +1 @@
+compact_pinned: compaction failed: cannot compact pinned objects
diff --git a/libraries/compact/tests/compact_serialize.hs b/libraries/compact/tests/compact_serialize.hs
index e4ba88ea9e..2b831e048c 100644
--- a/libraries/compact/tests/compact_serialize.hs
+++ b/libraries/compact/tests/compact_serialize.hs
@@ -10,6 +10,7 @@ import Foreign.Ptr
 import Control.DeepSeq
 
 import Data.Compact
+import Data.Compact.Internal
 import Data.Compact.Serialized
 
 assertFail :: String -> IO ()
@@ -23,7 +24,7 @@ assertEquals expected actual =
 
 serialize :: NFData a => a -> IO (SerializedCompact a, [ByteString])
 serialize val = do
-  cnf <- newCompact 4096 val
+  cnf <- compactSized 4096 True val
 
   bytestrref <- newIORef undefined
   scref <- newIORef undefined
diff --git a/libraries/compact/tests/compact_share.hs b/libraries/compact/tests/compact_share.hs
new file mode 100644
index 0000000000..73654e430b
--- /dev/null
+++ b/libraries/compact/tests/compact_share.hs
@@ -0,0 +1,14 @@
+import Data.Compact
+import Data.Compact.Internal
+import qualified Data.Map as Map
+
+main = do
+  let m1 = Map.fromList [(x,show x) | x <- [1..(10000::Integer)]]
+      m2 = Map.fromList [(x,y) | x <- [1..(10000::Integer)],
+                                 Just y <- [Map.lookup x m1]]
+  c <- compact (m1,m2)
+  print (length (show (getCompact c)))
+  print =<< compactSize c
+  c <- compactWithSharing (m1,m2)
+  print (length (show (getCompact c)))
+  print =<< compactSize c
diff --git a/libraries/compact/tests/compact_share.stdout b/libraries/compact/tests/compact_share.stdout
new file mode 100644
index 0000000000..0969fdf956
--- /dev/null
+++ b/libraries/compact/tests/compact_share.stdout
@@ -0,0 +1,4 @@
+275599
+3801088
+275599
+2228224
diff --git a/libraries/compact/tests/compact_simple.hs b/libraries/compact/tests/compact_simple.hs
index c4cfbbd151..83b24da4e7 100644
--- a/libraries/compact/tests/compact_simple.hs
+++ b/libraries/compact/tests/compact_simple.hs
@@ -18,7 +18,7 @@ assertEquals expected actual =
 test func = do
   let val = ("hello", 1, 42, 42, Just 42) ::
         (String, Int, Int, Integer, Maybe Int)
-  str <- func 4096 val
+  str <- func val
 
   -- check that val is still good
   assertEquals ("hello", 1, 42, 42, Just 42) val
@@ -30,6 +30,8 @@ test func = do
   -- check again the value in the compact
   assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str)
 
+  print =<< compactSize str
+
 main = do
-  test newCompact
-  test newCompactNoShare
+  test compactWithSharing
+  test compact
diff --git a/libraries/compact/tests/compact_simple.stdout b/libraries/compact/tests/compact_simple.stdout
new file mode 100644
index 0000000000..5549a58580
--- /dev/null
+++ b/libraries/compact/tests/compact_simple.stdout
@@ -0,0 +1,2 @@
+32768
+32768
diff --git a/libraries/compact/tests/compact_simple_array.hs b/libraries/compact/tests/compact_simple_array.hs
index 7b194867de..69421c5137 100644
--- a/libraries/compact/tests/compact_simple_array.hs
+++ b/libraries/compact/tests/compact_simple_array.hs
@@ -11,6 +11,7 @@ import qualified Data.Array.Unboxed as U
 import Control.DeepSeq
 
 import Data.Compact
+import Data.Compact.Internal
 
 assertFail :: String -> IO ()
 assertFail msg = throwIO $ AssertionFailed msg
@@ -45,7 +46,7 @@ test func = do
       unboxedFrozen = runSTUArray arrTest
 
   let val = (fromList, frozen, stFrozen, unboxedFrozen)
-  str <- func 4096 val
+  str <- func val
 
   -- check that val is still good
   assertEquals (fromList, frozen, stFrozen, unboxedFrozen) val
@@ -56,5 +57,5 @@ test func = do
   assertEquals val (getCompact str)
 
 main = do
-  test newCompact
-  test newCompactNoShare
+  test (compactSized 4096 True)
+  test (compactSized 4096 False)
diff --git a/libraries/compact/tests/compact_threads.hs b/libraries/compact/tests/compact_threads.hs
new file mode 100644
index 0000000000..99d6fe2409
--- /dev/null
+++ b/libraries/compact/tests/compact_threads.hs
@@ -0,0 +1,21 @@
+import Control.Concurrent
+import Control.Monad
+import Data.Compact
+import Data.Compact.Internal
+import qualified Data.Map as Map
+import Data.Maybe
+import System.Environment
+
+main = do
+  [n] <- map read <$> getArgs
+  c <- compact ()
+  as <- forM [1..(n::Int)] $ \i -> async (compactAdd c (Just i))
+  bs <- forM as $ \a -> async (getCompact <$> takeMVar a)
+  xs <- mapM takeMVar bs
+  print (sum (catMaybes xs))
+
+async :: IO a -> IO (MVar a)
+async io = do
+  m <- newEmptyMVar
+  forkIO (io >>= putMVar m)
+  return m
diff --git a/libraries/compact/tests/compact_threads.stdout b/libraries/compact/tests/compact_threads.stdout
new file mode 100644
index 0000000000..837e12b406
--- /dev/null
+++ b/libraries/compact/tests/compact_threads.stdout
@@ -0,0 +1 @@
+500500