Rename compact to ghc-compact.

Summary:
The plan is to release a separate library, 'compact', which gives a
friendly user-facing interface.  This library is just enough so that we
can make sure the functionality is working in GHC.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: bgamari, dfeuer, austin, simonmar, hvr

Subscribers: thomie, erikd, snowleopard

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

29 files changed, 483 insertions, 0 deletions

diff --git a/libraries/ghc-compact/tests/.gitignore b/libraries/ghc-compact/tests/.gitignore
new file mode 100644
index 0000000000..8887a1bbea
--- /dev/null
+++ b/libraries/ghc-compact/tests/.gitignore
@@ -0,0 +1,18 @@
+.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/ghc-compact/tests/Makefile b/libraries/ghc-compact/tests/Makefile
new file mode 100644
index 0000000000..6a0abcf1cf
--- /dev/null
+++ b/libraries/ghc-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/ghc-compact/tests/all.T b/libraries/ghc-compact/tests/all.T
new file mode 100644
index 0000000000..753592e733
--- /dev/null
+++ b/libraries/ghc-compact/tests/all.T
@@ -0,0 +1,19 @@
+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', ignore_stdout, 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/ghc-compact/tests/compact_append.hs b/libraries/ghc-compact/tests/compact_append.hs
new file mode 100644
index 0000000000..274c0bf429
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_append.hs
@@ -0,0 +1,38 @@
+module Main where
+
+import Control.Exception
+import System.Mem
+
+import GHC.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 <- compactWithSharing val
+
+  let val2 = ("world", 42) :: (String, Int)
+  str2 <- compactAddWithSharing 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/ghc-compact/tests/compact_autoexpand.hs b/libraries/ghc-compact/tests/compact_autoexpand.hs
new file mode 100644
index 0000000000..c4d27d08f6
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_autoexpand.hs
@@ -0,0 +1,27 @@
+module Main where
+
+import Control.Exception
+import System.Mem
+
+import GHC.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 <- compactSized 1 True val
+  assertEquals val (getCompact str)
+  performMajorGC
+  assertEquals val (getCompact str)
diff --git a/libraries/ghc-compact/tests/compact_bench.hs b/libraries/ghc-compact/tests/compact_bench.hs
new file mode 100644
index 0000000000..fa249dcc36
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_bench.hs
@@ -0,0 +1,27 @@
+import Control.Exception
+import GHC.Compact
+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/ghc-compact/tests/compact_bytestring.hs b/libraries/ghc-compact/tests/compact_bytestring.hs
new file mode 100644
index 0000000000..61a50df9c2
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_bytestring.hs
@@ -0,0 +1,7 @@
+import qualified Data.ByteString.Char8 as B
+import GHC.Compact
+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/ghc-compact/tests/compact_cycle.hs b/libraries/ghc-compact/tests/compact_cycle.hs
new file mode 100644
index 0000000000..54047e0c76
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_cycle.hs
@@ -0,0 +1,9 @@
+import Control.Exception
+import GHC.Compact
+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/ghc-compact/tests/compact_cycle.stdout b/libraries/ghc-compact/tests/compact_cycle.stdout
new file mode 100644
index 0000000000..6fc8a53046
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_cycle.stdout
@@ -0,0 +1,2 @@
+102
+32768
diff --git a/libraries/ghc-compact/tests/compact_function.hs b/libraries/ghc-compact/tests/compact_function.hs
new file mode 100644
index 0000000000..166f345552
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_function.hs
@@ -0,0 +1,6 @@
+import Control.Exception
+import GHC.Compact
+
+data HiddenFunction = HiddenFunction (Int -> Int)
+
+main = compact (HiddenFunction (+1))
diff --git a/libraries/ghc-compact/tests/compact_function.stderr b/libraries/ghc-compact/tests/compact_function.stderr
new file mode 100644
index 0000000000..197da0460b
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_function.stderr
@@ -0,0 +1 @@
+compact_function: compaction failed: cannot compact functions
diff --git a/libraries/ghc-compact/tests/compact_gc.hs b/libraries/ghc-compact/tests/compact_gc.hs
new file mode 100644
index 0000000000..2e13bafdbe
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_gc.hs
@@ -0,0 +1,11 @@
+import Control.Monad
+import GHC.Compact
+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/ghc-compact/tests/compact_huge_array.hs b/libraries/ghc-compact/tests/compact_huge_array.hs
new file mode 100644
index 0000000000..85694f5d9a
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_huge_array.hs
@@ -0,0 +1,56 @@
+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 GHC.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
+
+-- 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/ghc-compact/tests/compact_largemap.hs b/libraries/ghc-compact/tests/compact_largemap.hs
new file mode 100644
index 0000000000..bc918c905b
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_largemap.hs
@@ -0,0 +1,9 @@
+import GHC.Compact
+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/ghc-compact/tests/compact_largemap.stdout b/libraries/ghc-compact/tests/compact_largemap.stdout
new file mode 100644
index 0000000000..4825984a93
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_largemap.stdout
@@ -0,0 +1,2 @@
+137798
+137798
diff --git a/libraries/ghc-compact/tests/compact_loop.hs b/libraries/ghc-compact/tests/compact_loop.hs
new file mode 100644
index 0000000000..40e0817dfe
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_loop.hs
@@ -0,0 +1,42 @@
+module Main where
+
+import Control.Exception
+import System.Mem
+import Text.Show
+
+import GHC.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 ")"
+
+{-# NOINLINE test #-}
+test x = do
+  let a = Node Nil x b
+      b = Node a Nil Nil
+  str <- compactSized 4096 True 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/ghc-compact/tests/compact_mutable.hs b/libraries/ghc-compact/tests/compact_mutable.hs
new file mode 100644
index 0000000000..33a405452d
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_mutable.hs
@@ -0,0 +1,9 @@
+import Control.Concurrent
+import Control.Exception
+import GHC.Compact
+
+data HiddenMVar = HiddenMVar (MVar ())
+
+main = do
+  m <- newEmptyMVar
+  compact (HiddenMVar m)
diff --git a/libraries/ghc-compact/tests/compact_mutable.stderr b/libraries/ghc-compact/tests/compact_mutable.stderr
new file mode 100644
index 0000000000..9a4bd2892e
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_mutable.stderr
@@ -0,0 +1 @@
+compact_mutable: compaction failed: cannot compact mutable objects
diff --git a/libraries/ghc-compact/tests/compact_pinned.hs b/libraries/ghc-compact/tests/compact_pinned.hs
new file mode 100644
index 0000000000..16eff0da8a
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_pinned.hs
@@ -0,0 +1,5 @@
+import Control.Exception
+import qualified Data.ByteString.Char8 as B
+import GHC.Compact
+
+main = compact (B.pack ['a'..'c'])
diff --git a/libraries/ghc-compact/tests/compact_pinned.stderr b/libraries/ghc-compact/tests/compact_pinned.stderr
new file mode 100644
index 0000000000..1f470a0d49
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_pinned.stderr
@@ -0,0 +1 @@
+compact_pinned: compaction failed: cannot compact pinned objects
diff --git a/libraries/ghc-compact/tests/compact_serialize.hs b/libraries/ghc-compact/tests/compact_serialize.hs
new file mode 100644
index 0000000000..ff8e0cfa14
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_serialize.hs
@@ -0,0 +1,52 @@
+module Main where
+
+import Control.Exception
+import Control.Monad
+import System.Mem
+
+import Data.IORef
+import Data.ByteString (ByteString, packCStringLen)
+import Foreign.Ptr
+
+import GHC.Compact
+import GHC.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 :: a -> IO (SerializedCompact a, [ByteString])
+serialize val = do
+  cnf <- compactSized 4096 True 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/ghc-compact/tests/compact_serialize.stderr b/libraries/ghc-compact/tests/compact_serialize.stderr
new file mode 100644
index 0000000000..2483efa009
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_serialize.stderr
@@ -0,0 +1 @@
+Compact imported at the wrong address, will fix up internal pointers
diff --git a/libraries/ghc-compact/tests/compact_share.hs b/libraries/ghc-compact/tests/compact_share.hs
new file mode 100644
index 0000000000..323c179cca
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_share.hs
@@ -0,0 +1,13 @@
+import GHC.Compact
+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/ghc-compact/tests/compact_share.stdout b/libraries/ghc-compact/tests/compact_share.stdout
new file mode 100644
index 0000000000..0969fdf956
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_share.stdout
@@ -0,0 +1,4 @@
+275599
+3801088
+275599
+2228224
diff --git a/libraries/ghc-compact/tests/compact_simple.hs b/libraries/ghc-compact/tests/compact_simple.hs
new file mode 100644
index 0000000000..28575d20d0
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_simple.hs
@@ -0,0 +1,37 @@
+module Main where
+
+import Control.Exception
+import System.Mem
+
+import GHC.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 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)
+
+  print =<< compactSize str
+
+main = do
+  test compactWithSharing
+  test compact
diff --git a/libraries/ghc-compact/tests/compact_simple.stdout b/libraries/ghc-compact/tests/compact_simple.stdout
new file mode 100644
index 0000000000..5549a58580
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_simple.stdout
@@ -0,0 +1,2 @@
+32768
+32768
diff --git a/libraries/ghc-compact/tests/compact_simple_array.hs b/libraries/ghc-compact/tests/compact_simple_array.hs
new file mode 100644
index 0000000000..b897e610f4
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_simple_array.hs
@@ -0,0 +1,56 @@
+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 GHC.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
+
+-- 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 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/ghc-compact/tests/compact_threads.hs b/libraries/ghc-compact/tests/compact_threads.hs
new file mode 100644
index 0000000000..162612d034
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_threads.hs
@@ -0,0 +1,20 @@
+import Control.Concurrent
+import Control.Monad
+import GHC.Compact
+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/ghc-compact/tests/compact_threads.stdout b/libraries/ghc-compact/tests/compact_threads.stdout
new file mode 100644
index 0000000000..837e12b406
--- /dev/null
+++ b/libraries/ghc-compact/tests/compact_threads.stdout
@@ -0,0 +1 @@
+500500