[commit: ghc] wip/closure-size: ghc-heap: Introduce closureSize (18a9b51)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/closure-size
Link       : http://ghc.haskell.org/trac/ghc/changeset/18a9b51a2bef1ab00383fd21586bbbd2f4c73634/ghc

>---------------------------------------------------------------

commit 18a9b51a2bef1ab00383fd21586bbbd2f4c73634
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Mar 13 19:42:47 2019 -0400

    ghc-heap: Introduce closureSize
    
    This function allows the user to compute the (non-transitive) size of a
    heap object in words. The "closure" in the name is admittedly confusing
    but we are stuck with this nomenclature at this point.


>---------------------------------------------------------------

18a9b51a2bef1ab00383fd21586bbbd2f4c73634
 libraries/ghc-heap/GHC/Exts/Heap/Closures.hs       | 10 ++++++++
 libraries/ghc-heap/cbits/HeapPrim.cmm              |  7 +++++
 libraries/ghc-heap/tests/all.T                     |  3 +++
 libraries/ghc-heap/tests/closure_size.hs           | 30 ++++++++++++++++++++++
 .../tests/closure_size.stdout}                     |  0
 5 files changed, 50 insertions(+)

diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index e624a17..d04cde5 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -13,6 +13,7 @@ module GHC.Exts.Heap.Closures (
     , GenClosure(..)
     , PrimType(..)
     , allClosures
+    , closureSize
 
     -- * Boxes
     , Box(..)
@@ -49,6 +50,9 @@ foreign import prim "aToWordzh" aToWord# :: Any -> Word#
 foreign import prim "reallyUnsafePtrEqualityUpToTag"
     reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
 
+foreign import prim "closureSizezh"
+    closureSize# :: Any -> Int#
+
 -- | An arbitrary Haskell value in a safe Box. The point is that even
 -- unevaluated thunks can safely be moved around inside the Box, and when
 -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
@@ -321,3 +325,9 @@ allClosures (FunClosure {..}) = ptrArgs
 allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
 allClosures (OtherClosure {..}) = hvalues
 allClosures _ = []
+
+-- | Get the size of a closure in words.
+--
+-- @since 8.10.1
+closureSize :: Box -> Int
+closureSize x = closureSize# x
diff --git a/libraries/ghc-heap/cbits/HeapPrim.cmm b/libraries/ghc-heap/cbits/HeapPrim.cmm
index 915786d..cc5b8a6 100644
--- a/libraries/ghc-heap/cbits/HeapPrim.cmm
+++ b/libraries/ghc-heap/cbits/HeapPrim.cmm
@@ -11,3 +11,10 @@ reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)
     clos2 = UNTAG(clos2);
     return (clos1 == clos2);
 }
+
+closureSizezh (P_ clos)
+{
+    W_ len;
+    (len) = foreign "C" heap_view_closureSize(clos "ptr");
+    return (len);
+}
diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T
index a676b49..9fc3fbe 100644
--- a/libraries/ghc-heap/tests/all.T
+++ b/libraries/ghc-heap/tests/all.T
@@ -6,3 +6,6 @@ test('heap_all',
       omit_ways(['ghci', 'hpc'])
      ],
      compile_and_run, [''])
+test('closure_size',
+     omit_ways(['ghci', 'hpc']),
+     compile_and_run, [''])
diff --git a/libraries/ghc-heap/tests/closure_size.hs b/libraries/ghc-heap/tests/closure_size.hs
new file mode 100644
index 0000000..40e904e
--- /dev/null
+++ b/libraries/ghc-heap/tests/closure_size.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.Monad
+import Type.Reflection
+
+import GHC.Exts.Heap.Closures
+
+assertSize :: forall a. Typeable a => a -> Int -> IO ()
+assertSize !x n = do
+  let !size = closureSize (asBox x)
+  when (size != expected) $ do
+    putStrLn $ "closureSize ("++show (typeRep @a)++") == "++show size++", expected "++show expected
+{-# NOINLINE assertSize #-}
+
+pap :: Int -> Char -> Int
+pap x _ = x
+{-# NOINLINE pap #-}
+
+main :: IO ()
+main = do
+  assertSize 'a' 2
+  assertSize (Just ()) 2
+  assertSize (1,2) 3
+  assertSize (1,2,3) 4
+  assertSize id 1
+  assertSize fst 1
+  assertSize (pap 1) 2
+
diff --git a/libraries/ghc-compact/tests/compact_serialize.stderr b/libraries/ghc-heap/tests/closure_size.stdout
similarity index 100%
copy from libraries/ghc-compact/tests/compact_serialize.stderr
copy to libraries/ghc-heap/tests/closure_size.stdout