ghc-heap: Introduce closureSize
authorBen Gamari <ben@smart-cactus.org>
Wed, 13 Mar 2019 23:42:47 +0000 (19:42 -0400)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Sun, 17 Mar 2019 09:05:10 +0000 (05:05 -0400)
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.

compiler/prelude/primops.txt.pp
includes/stg/MiscClosures.h
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
libraries/ghc-heap/tests/all.T
libraries/ghc-heap/tests/closure_size.hs [new file with mode: 0644]
libraries/ghc-heap/tests/closure_size.stdout [new file with mode: 0644]
libraries/ghc-prim/changelog.md
rts/PrimOps.cmm
rts/RtsSymbols.c

index 94de07f..6a1be8a 100644 (file)
@@ -3208,6 +3208,13 @@ primop  UnpackClosureOp "unpackClosure#" GenPrimOp
    with
    out_of_line = True
 
+primop  ClosureSizeOp "closureSize#" GenPrimOp
+   a -> Int#
+   { {\tt closureSize\# closure} returns the size of the given closure in
+     machine words. }
+   with
+   out_of_line = True
+
 primop  GetApStackValOp "getApStackVal#" GenPrimOp
    a -> Int# -> (# Int#, b #)
    with
index 8c4cb9f..0fc904e 100644 (file)
@@ -470,6 +470,7 @@ RTS_FUN_DECL(stg_readTVarIOzh);
 RTS_FUN_DECL(stg_writeTVarzh);
 
 RTS_FUN_DECL(stg_unpackClosurezh);
+RTS_FUN_DECL(stg_closureSizzezh);
 RTS_FUN_DECL(stg_getApStackValzh);
 RTS_FUN_DECL(stg_getSparkzh);
 RTS_FUN_DECL(stg_numSparkszh);
index e624a17..2465014 100644 (file)
@@ -13,6 +13,12 @@ module GHC.Exts.Heap.Closures (
     , GenClosure(..)
     , PrimType(..)
     , allClosures
+#if __GLASGOW_HASKELL__ >= 809
+    -- The closureSize# primop is unsupported on earlier GHC releases but we
+    -- build ghc-heap as a boot library so it must be buildable. Drop this once
+    -- we are guaranteed to bootstsrap with GHC >= 8.9.
+    , closureSize
+#endif
 
     -- * Boxes
     , Box(..)
@@ -321,3 +327,11 @@ allClosures (FunClosure {..}) = ptrArgs
 allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
 allClosures (OtherClosure {..}) = hvalues
 allClosures _ = []
+
+#if __GLASGOW_HASKELL__ >= 809
+-- | Get the size of a closure in words.
+--
+-- @since 8.10.1
+closureSize :: Box -> Int
+closureSize (Box x) = I# (closureSize# x)
+#endif
index a676b49..595bd00 100644 (file)
@@ -6,3 +6,6 @@ test('heap_all',
       omit_ways(['ghci', 'hpc'])
      ],
      compile_and_run, [''])
+test('closure_size',
+     omit_ways(['ghci', 'hpc', 'prof']),
+     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 (file)
index 0000000..d770607
--- /dev/null
@@ -0,0 +1,34 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.Monad
+import Type.Reflection
+import GHC.Stack
+
+import GHC.Exts.Heap.Closures
+
+assertSize :: forall a. (HasCallStack, Typeable a)
+           => a -> Int -> IO ()
+assertSize !x expected = do
+  let !size = closureSize (asBox x)
+  when (size /= expected) $ do
+    putStrLn $ "closureSize ("++show (typeRep @a)++") == "++show size++", expected "++show expected
+    putStrLn $ prettyCallStack callStack
+{-# NOINLINE assertSize #-}
+
+pap :: Int -> Char -> Int
+pap x _ = x
+{-# NOINLINE pap #-}
+
+main :: IO ()
+main = do
+  assertSize 'a' 2
+  assertSize (Just ()) 2
+  assertSize (Nothing :: Maybe ()) 2
+  assertSize ((1,2) :: (Int,Int)) 3
+  assertSize ((1,2,3) :: (Int,Int,Int)) 4
+  assertSize (id :: Int -> Int) 1
+  assertSize (fst :: (Int,Int) -> Int) 1
+  assertSize (pap 1) 2
+
diff --git a/libraries/ghc-heap/tests/closure_size.stdout b/libraries/ghc-heap/tests/closure_size.stdout
new file mode 100644 (file)
index 0000000..e69de29
index ecbc93f..2298846 100644 (file)
@@ -1,3 +1,11 @@
+## 0.6.1
+
+- Shipped with GHC 8.10.1
+
+- Added to `GHC.Prim`:
+
+        closureSize# :: a -> Int#
+
 ## 0.6.0
 
 - Shipped with GHC 8.8.1
index 625f5f5..bc89839 100644 (file)
@@ -2041,6 +2041,13 @@ for:
     return (info, dat_arr, ptrArray);
 }
 
+stg_closureSizzezh (P_ clos)
+{
+    W_ len;
+    (len) = foreign "C" heap_view_closureSize(UNTAG(clos) "ptr");
+    return (len);
+}
+
 /* -----------------------------------------------------------------------------
    Thread I/O blocking primitives
    -------------------------------------------------------------------------- */
index 6966d6d..eb0322e 100644 (file)
       SymI_HasProto(initLinker)                                         \
       SymI_HasProto(initLinker_)                                        \
       SymI_HasProto(stg_unpackClosurezh)                                \
+      SymI_HasProto(stg_closureSizzezh)                                 \
       SymI_HasProto(stg_getApStackValzh)                                \
       SymI_HasProto(stg_getSparkzh)                                     \
       SymI_HasProto(stg_numSparkszh)                                    \