[commit: ghc] master, wip/fix-ghci-ci, wip/pat-builder: ghc-heap: Introduce closureSize (cb61371)
git at git.haskell.org
git at git.haskell.org
Sun Mar 17 19:08:04 UTC 2019
Repository : ssh://git@git.haskell.org/ghc
On branches: master,wip/fix-ghci-ci,wip/pat-builder
Link : http://ghc.haskell.org/trac/ghc/changeset/cb61371e3260e07be724a04b72a935133f66b514/ghc
>---------------------------------------------------------------
commit cb61371e3260e07be724a04b72a935133f66b514
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.
>---------------------------------------------------------------
cb61371e3260e07be724a04b72a935133f66b514
compiler/prelude/primops.txt.pp | 7 +++++
includes/stg/MiscClosures.h | 1 +
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 14 +++++++++
libraries/ghc-heap/tests/all.T | 3 ++
libraries/ghc-heap/tests/closure_size.hs | 34 ++++++++++++++++++++++
.../tests/closure_size.stdout} | 0
libraries/ghc-prim/changelog.md | 8 +++++
rts/PrimOps.cmm | 7 +++++
rts/RtsSymbols.c | 1 +
9 files changed, 75 insertions(+)
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 94de07f..6a1be8a 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -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
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 8c4cb9f..0fc904e 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -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);
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index e624a17..2465014 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -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
diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T
index a676b49..595bd00 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', '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
index 0000000..d770607
--- /dev/null
+++ b/libraries/ghc-heap/tests/closure_size.hs
@@ -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-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
diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md
index ecbc93f..2298846 100644
--- a/libraries/ghc-prim/changelog.md
+++ b/libraries/ghc-prim/changelog.md
@@ -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
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 625f5f5..bc89839 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -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
-------------------------------------------------------------------------- */
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 6966d6d..eb0322e 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -631,6 +631,7 @@
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) \
More information about the ghc-commits
mailing list