diff options
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 7 | ||||
| -rw-r--r-- | includes/stg/MiscClosures.h | 1 | ||||
| -rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 14 | ||||
| -rw-r--r-- | libraries/ghc-heap/tests/all.T | 3 | ||||
| -rw-r--r-- | libraries/ghc-heap/tests/closure_size.hs | 34 | ||||
| -rw-r--r-- | libraries/ghc-heap/tests/closure_size.stdout | 0 | ||||
| -rw-r--r-- | libraries/ghc-prim/changelog.md | 8 | ||||
| -rw-r--r-- | rts/PrimOps.cmm | 7 | ||||
| -rw-r--r-- | rts/RtsSymbols.c | 1 |
9 files changed, 75 insertions, 0 deletions
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 94de07f8e5..6a1be8a486 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 8c4cb9fc8c..0fc904e770 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 e624a17b78..2465014e48 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 a676b4971a..595bd000d4 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 0000000000..d77060779e --- /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-heap/tests/closure_size.stdout b/libraries/ghc-heap/tests/closure_size.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/libraries/ghc-heap/tests/closure_size.stdout diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index ecbc93fea4..2298846cd1 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 625f5f5ab3..bc89839aec 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 6966d6deb9..eb0322ed3e 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) \ |