Compact Regions

This brings in initial support for compact regions, as described in the
ICFP 2015 paper "Efficient Communication and Collection with Compact
Normal Forms" (Edward Z. Yang et.al.) and implemented by Giovanni
Campagna.

Some things may change before the 8.2 release, but I (Simon M.) wanted
to get the main patch committed so that we can iterate.

What documentation there is is in the Data.Compact module in the new
compact package.  We'll need to extend and polish the documentation
before the release.

Test Plan:
validate
(new test cases included)

Reviewers: ezyang, simonmar, hvr, bgamari, austin

Subscribers: vikraman, Yuras, RyanGlScott, qnikst, mboes, facundominguez, rrnewton, thomie, erikd

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

GHC Trac Issues: #11493

18 files changed, 790 insertions, 0 deletions

diff --git a/libraries/compact/.gitignore b/libraries/compact/.gitignore
new file mode 100644
index 0000000000..89cf73d0b3
--- /dev/null
+++ b/libraries/compact/.gitignore
@@ -0,0 +1,4 @@
+GNUmakefile
+/dist-install/
+/dist/
+ghc.mk
diff --git a/libraries/compact/Data/Compact.hs b/libraries/compact/Data/Compact.hs
new file mode 100644
index 0000000000..7cedd1c27a
--- /dev/null
+++ b/libraries/compact/Data/Compact.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.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 fully evaluated data in a consecutive block of memory.
+--
+-- /Since: 1.0.0/
+module Data.Compact (
+  Compact,
+  getCompact,
+  inCompact,
+  isCompact,
+
+  newCompact,
+  newCompactNoShare,
+  appendCompact,
+  appendCompactNoShare,
+  ) 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
+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#
diff --git a/libraries/compact/Data/Compact/Internal.hs b/libraries/compact/Data/Compact/Internal.hs
new file mode 100644
index 0000000000..36cd438b1e
--- /dev/null
+++ b/libraries/compact/Data/Compact/Internal.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Compact.Internal
+-- Copyright   :  (c) The University of Glasgow 2001-2009
+--                (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015
+-- 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 fully evaluated data in a consecutive block of memory.
+--
+-- This is a private implementation detail of the package and should
+-- not be imported directly.
+--
+-- /Since: 1.0.0/
+
+module Data.Compact.Internal(
+  Compact(..),
+  compactResize,
+  isCompact,
+  inCompact,
+
+  compactAppendEvaledInternal,
+) where
+
+-- 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 #) )
+
+compactResize :: Compact a -> Word -> IO ()
+compactResize (Compact oldBuffer _) (W# new_size) =
+  IO (\s -> case compactResize# oldBuffer new_size s of
+         s' -> (# s', () #) )
+
+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 #)
diff --git a/libraries/compact/Data/Compact/Serialized.hs b/libraries/compact/Data/Compact/Serialized.hs
new file mode 100644
index 0000000000..e58f9eef83
--- /dev/null
+++ b/libraries/compact/Data/Compact/Serialized.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Compact.Serialized
+-- Copyright   :  (c) The University of Glasgow 2001-2009
+--                (c) Giovanni Campagna <gcampagn@cs.stanford.edu> 2015
+-- 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 fully evaluated data in a consecutive block of memory.
+--
+-- This module contains support for serializing a Compact for network
+-- transmission and on-disk storage.
+--
+-- /Since: 1.0.0/
+
+module Data.Compact.Serialized(
+  SerializedCompact(..),
+  withSerializedCompact,
+  importCompact,
+  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.Word (Word8)
+
+import GHC.Ptr (Ptr(..), plusPtr)
+
+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 Control.DeepSeq(NFData, force)
+
+import Data.Compact.Internal(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. The resulting
+-- action will be executed synchronously before this function
+-- completes.
+{-# NOINLINE withSerializedCompact #-}
+withSerializedCompact :: NFData c => Compact a ->
+                         (SerializedCompact a -> IO c) -> IO c
+withSerializedCompact (Compact buffer root) func = do
+  rootPtr <- IO (\s -> case anyToAddr# root s of
+                    (# s', rootAddr #) -> (# s', Ptr rootAddr #) )
+  blockList <- mkBlockList buffer
+  let serialized = SerializedCompact blockList rootPtr
+  -- we must be strict, to avoid smart uses of ByteStrict.Lazy that
+  -- return a thunk instead of a ByteString (but the thunk references
+  -- the Ptr, not the Compact#, so it will point to garbage if GC
+  -- happens)
+  !r <- fmap force $ 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 #) -> (# s', Just $ Compact buffer root #)
+
+-- |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
+
+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/libraries/compact/LICENSE b/libraries/compact/LICENSE
new file mode 100644
index 0000000000..06b2599694
--- /dev/null
+++ b/libraries/compact/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/libraries/compact/README.md b/libraries/compact/README.md
new file mode 100644
index 0000000000..0b7d197c88
--- /dev/null
+++ b/libraries/compact/README.md
@@ -0,0 +1,5 @@
+The `compact` Package
+=====================
+
+Exposes a single data structure, called a Compact, which contains
+fully evaluated data closed under pointer reachability.
diff --git a/libraries/compact/Setup.hs b/libraries/compact/Setup.hs
new file mode 100644
index 0000000000..6fa548caf7
--- /dev/null
+++ b/libraries/compact/Setup.hs
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/libraries/compact/compact.cabal b/libraries/compact/compact.cabal
new file mode 100644
index 0000000000..9d87ccccd3
--- /dev/null
+++ b/libraries/compact/compact.cabal
@@ -0,0 +1,47 @@
+name:           compact
+version:        1.0.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/compact
+synopsis:       In memory storage of deeply evaluated data structure
+category:       Data
+description:
+    This package provides a single data structure, called a Compact,
+    which holds a single haskell object in fully evaluated form. The
+    invariant is, 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.
+build-type:     Simple
+cabal-version:  >=1.10
+tested-with:    GHC==7.11
+
+source-repository head
+  type:     git
+  location: http://git.haskell.org/ghc.git
+  subdir:   libraries/compact
+
+library
+  default-language: Haskell2010
+  other-extensions:
+    MagicHash
+    BangPatterns
+    UnboxedTuples
+    CPP
+
+  build-depends: rts        == 1.0.*
+  build-depends: ghc-prim   == 0.5.0.0
+  build-depends: base       >= 4.9.0 && < 4.10
+  build-depends: deepseq    >= 1.4
+  build-depends: bytestring >= 0.10.6.0
+  ghc-options: -Wall
+
+  exposed-modules: Data.Compact
+                   Data.Compact.Internal
+                   Data.Compact.Serialized
diff --git a/libraries/compact/tests/.gitignore b/libraries/compact/tests/.gitignore
new file mode 100644
index 0000000000..c20cf7d4be
--- /dev/null
+++ b/libraries/compact/tests/.gitignore
@@ -0,0 +1,21 @@
+*.stderr
+!compact_serialize.stderr
+*.stdout
+.hpc.*
+*.eventlog
+*.genscript
+compact_append
+compact_simple
+compact_nospace
+compact_noshare
+compact_loop
+compact_resize
+compact_inc_append
+compact_inc_simple
+compact_inc_nospace
+compact_inc_noshare
+compact_autoexpand
+compact_inc_custom
+compact_inc_incremental
+compact_inc_monad
+compact_simple_symbols  
diff --git a/libraries/compact/tests/Makefile b/libraries/compact/tests/Makefile
new file mode 100644
index 0000000000..6a0abcf1cf
--- /dev/null
+++ b/libraries/compact/tests/Makefile
@@ -0,0 +1,7 @@
+# This Makefile runs the tests using GHC's testsuite framework.  It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/libraries/compact/tests/all.T b/libraries/compact/tests/all.T
new file mode 100644
index 0000000000..fd543142e9
--- /dev/null
+++ b/libraries/compact/tests/all.T
@@ -0,0 +1,6 @@
+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
diff --git a/libraries/compact/tests/compact_append.hs b/libraries/compact/tests/compact_append.hs
new file mode 100644
index 0000000000..59f86777b7
--- /dev/null
+++ b/libraries/compact/tests/compact_append.hs
@@ -0,0 +1,38 @@
+module Main where
+
+import Control.Exception
+import System.Mem
+
+import Data.Compact
+
+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)
+
+main = do
+  let val = ("hello", Just 42) :: (String, Maybe Int)
+  str <- newCompact 4096 val
+
+  let val2 = ("world", 42) :: (String, Int)
+  str2 <- appendCompact str val2
+
+  -- check that values where not corrupted
+  assertEquals ("hello", Just 42) val
+  assertEquals ("world", 42) val2
+  -- check the values in the compact
+  assertEquals ("hello", Just 42) (getCompact str)
+  assertEquals ("world", 42) (getCompact str2)
+
+  performMajorGC
+
+  -- same checks again
+  assertEquals ("hello", Just 42) val
+  assertEquals ("world", 42) val2
+  -- check the values in the compact
+  assertEquals ("hello", Just 42) (getCompact str)
+  assertEquals ("world", 42) (getCompact str2)
diff --git a/libraries/compact/tests/compact_autoexpand.hs b/libraries/compact/tests/compact_autoexpand.hs
new file mode 100644
index 0000000000..5db0bbc55f
--- /dev/null
+++ b/libraries/compact/tests/compact_autoexpand.hs
@@ -0,0 +1,27 @@
+module Main where
+
+import Control.Exception
+import System.Mem
+
+import Data.Compact
+
+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)
+
+main = do
+  -- create a compact large 4096 bytes (minus the size of header)
+  -- add a value that is 1024 cons cells, pointing to 7 INTLIKE
+  -- each cons cell is 1 word header, 1 word data, 1 word next
+  -- 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
+  assertEquals val (getCompact str)
+  performMajorGC
+  assertEquals val (getCompact str)
diff --git a/libraries/compact/tests/compact_loop.hs b/libraries/compact/tests/compact_loop.hs
new file mode 100644
index 0000000000..0111fc1bdb
--- /dev/null
+++ b/libraries/compact/tests/compact_loop.hs
@@ -0,0 +1,47 @@
+module Main where
+
+import Control.Exception
+import Control.DeepSeq
+import System.Mem
+import Text.Show
+
+import Data.Compact
+
+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)
+
+data Tree = Nil | Node Tree Tree Tree
+
+instance Eq Tree where
+  Nil == Nil = True
+  Node _ l1 r1 == Node _ l2 r2 = l1 == l2 && r1 == r2
+  _ == _ = False
+
+instance Show Tree where
+  showsPrec _ Nil = showString "Nil"
+  showsPrec _ (Node _ l r) = showString "(Node " . shows l .
+                             showString " " . shows r . showString ")"
+
+instance NFData Tree where
+  rnf Nil = ()
+  rnf (Node p l r) = p `seq` rnf l `seq` rnf r `seq` ()
+
+{-# NOINLINE test #-}
+test x = do
+  let a = Node Nil x b
+      b = Node a Nil Nil
+  str <- newCompact 4096 a
+
+  -- check the value in the compact
+  assertEquals a (getCompact str)
+  performMajorGC
+  -- check again the value in the compact
+  assertEquals a (getCompact str)
+
+main = test Nil
diff --git a/libraries/compact/tests/compact_serialize.hs b/libraries/compact/tests/compact_serialize.hs
new file mode 100644
index 0000000000..e4ba88ea9e
--- /dev/null
+++ b/libraries/compact/tests/compact_serialize.hs
@@ -0,0 +1,53 @@
+module Main where
+
+import Control.Exception
+import Control.Monad
+import System.Mem
+
+import Data.IORef
+import Data.ByteString (ByteString, packCStringLen)
+import Foreign.Ptr
+import Control.DeepSeq
+
+import Data.Compact
+import Data.Compact.Serialized
+
+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)
+
+serialize :: NFData a => a -> IO (SerializedCompact a, [ByteString])
+serialize val = do
+  cnf <- newCompact 4096 val
+
+  bytestrref <- newIORef undefined
+  scref <- newIORef undefined
+  withSerializedCompact cnf $ \sc -> do
+    writeIORef scref sc
+    performMajorGC
+    bytestrs <- forM (serializedCompactBlockList sc) $ \(ptr, size) -> do
+      packCStringLen (castPtr ptr, fromIntegral size)
+    writeIORef bytestrref bytestrs
+
+  performMajorGC
+
+  bytestrs <- readIORef bytestrref
+  sc <- readIORef scref
+  return (sc, bytestrs)
+
+main = do
+  let val = ("hello", 1, 42, 42, Just 42) ::
+        (String, Int, Int, Integer, Maybe Int)
+
+  (sc, bytestrs) <- serialize val
+  performMajorGC
+
+  mcnf <- importCompactByteStrings sc bytestrs
+  case mcnf of
+    Nothing -> assertFail "import failed"
+    Just cnf -> assertEquals val (getCompact cnf)
diff --git a/libraries/compact/tests/compact_serialize.stderr b/libraries/compact/tests/compact_serialize.stderr
new file mode 100644
index 0000000000..2483efa009
--- /dev/null
+++ b/libraries/compact/tests/compact_serialize.stderr
@@ -0,0 +1 @@
+Compact imported at the wrong address, will fix up internal pointers
diff --git a/libraries/compact/tests/compact_simple.hs b/libraries/compact/tests/compact_simple.hs
new file mode 100644
index 0000000000..c4cfbbd151
--- /dev/null
+++ b/libraries/compact/tests/compact_simple.hs
@@ -0,0 +1,35 @@
+module Main where
+
+import Control.Exception
+import System.Mem
+
+import Data.Compact
+
+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)
+
+-- test :: (Word -> a -> IO (Maybe (Compact a))) -> IO ()
+test func = do
+  let val = ("hello", 1, 42, 42, Just 42) ::
+        (String, Int, Int, Integer, Maybe Int)
+  str <- func 4096 val
+
+  -- check that val is still good
+  assertEquals ("hello", 1, 42, 42, Just 42) val
+  -- check the value in the compact
+  assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str)
+  performMajorGC
+  -- check again val
+  assertEquals ("hello", 1, 42, 42, Just 42) val
+  -- check again the value in the compact
+  assertEquals ("hello", 1, 42, 42, Just 42) (getCompact str)
+
+main = do
+  test newCompact
+  test newCompactNoShare
diff --git a/libraries/compact/tests/compact_simple_array.hs b/libraries/compact/tests/compact_simple_array.hs
new file mode 100644
index 0000000000..7b194867de
--- /dev/null
+++ b/libraries/compact/tests/compact_simple_array.hs
@@ -0,0 +1,60 @@
+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
+
+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, 10) [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 4096 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 newCompact
+  test newCompactNoShare