[Git][ghc/ghc][wip/T25560] 3 commits: ghc-internal: Disallow setNumCapabilities beyond MAX_N_CAPABILITIES

[Ben Gamari (@bgamari)]

Ben Gamari pushed to branch wip/T25560 at Glasgow Haskell Compiler / GHC


Commits:
8b8b2b6c by Ben Gamari at 2024-12-06T18:45:08-05:00
ghc-internal: Disallow setNumCapabilities beyond MAX_N_CAPABILITIES

Throw an exception instead of segfault.

Fixes #25560.

- - - - -
58bc17d7 by Ben Gamari at 2024-12-06T18:45:08-05:00
ghc-internal: Fix inconsistent FFI import types

The foreign imports of `enabled_capabilities` and
`getNumberOfProcessors` were declared as `CInt` whereas they are defined
as `uint32_t`.

- - - - -
b327e6af by Ben Gamari at 2024-12-06T18:45:08-05:00
testsuite: Add test for #25560

- - - - -


7 changed files:

- libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
- rts/Capability.c
- rts/RtsSymbols.c
- rts/include/rts/Threads.h
- + testsuite/tests/rts/T25560.hs
- + testsuite/tests/rts/T25560.stderr
- testsuite/tests/rts/all.T


Changes:

=====================================
libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
=====================================
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RankNTypes #-}
@@ -381,8 +380,15 @@ to avoid contention with other processes in the machine.
 -}
 setNumCapabilities :: Int -> IO ()
 setNumCapabilities i
-  | i <= 0    = failIO $ "setNumCapabilities: Capability count ("++show i++") must be positive"
-  | otherwise = c_setNumCapabilities (fromIntegral i)
+  | i <= 0      = failIO $ "setNumCapabilities: Capability count ("++show i++") must be positive"
+  | i > maxCaps = failIO $ "setNumCapabilities: This GHC build only supports up to "++show maxCaps++" capabilities"
+  | otherwise   = c_setNumCapabilities (fromIntegral i)
+
+maxCaps :: Int
+maxCaps = unsafeDupablePerformIO $ peek c_maxNumCapabilities
+
+foreign import ccall safe "&maxNumCapabilities"
+  c_maxNumCapabilities :: Ptr Int
 
 foreign import ccall safe "setNumCapabilities"
   c_setNumCapabilities :: CUInt -> IO ()
@@ -394,13 +400,14 @@ getNumProcessors :: IO Int
 getNumProcessors = fmap fromIntegral c_getNumberOfProcessors
 
 foreign import ccall unsafe "getNumberOfProcessors"
-  c_getNumberOfProcessors :: IO CUInt
+  c_getNumberOfProcessors :: IO Word32
 
 -- | Returns the number of sparks currently in the local spark pool
 numSparks :: IO Int
 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
 
-foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt
+foreign import ccall "&enabled_capabilities"
+  enabled_capabilities :: Ptr Word32
 
 childHandler :: SomeException -> IO ()
 childHandler err = catch (real_handler err) childHandler


=====================================
rts/Capability.c
=====================================
@@ -16,6 +16,7 @@
  *
  * --------------------------------------------------------------------------*/
 
+#include "rts/Config.h"
 #include "rts/PosixSource.h"
 #include "Rts.h"
 
@@ -40,6 +41,9 @@ Capability MainCapability;
 uint32_t n_capabilities = 0;
 uint32_t enabled_capabilities = 0;
 
+// Referenced by GHC.Internal.Conc.Sync
+const StgInt maxNumCapabilities = MAX_N_CAPABILITIES;
+
 // The array of Capabilities.  It's important that when we need
 // to allocate more Capabilities we don't have to move the existing
 // Capabilities, because there may be pointers to them in use


=====================================
rts/RtsSymbols.c
=====================================
@@ -910,6 +910,7 @@ extern char **environ;
       SymI_HasProto(stopTimer)                                          \
       SymI_HasProto(n_capabilities)                                     \
       SymI_HasProto(enabled_capabilities)                               \
+      SymI_HasProto(maxNumCapabilities)                                 \
       SymI_HasDataProto(stg_traceEventzh)                                   \
       SymI_HasDataProto(stg_traceMarkerzh)                                  \
       SymI_HasDataProto(stg_traceBinaryEventzh)                             \


=====================================
rts/include/rts/Threads.h
=====================================
@@ -77,6 +77,8 @@ INLINE_HEADER unsigned int getNumCapabilities(void)
 // The number of Capabilities that are not disabled
 extern uint32_t enabled_capabilities;
 
+extern StgInt maxNumCapabilities;
+
 #if !IN_STG_CODE
 extern Capability MainCapability;
 #endif


=====================================
testsuite/tests/rts/T25560.hs
=====================================
@@ -0,0 +1,4 @@
+import GHC.Conc
+
+main :: IO ()
+main = setNumCapabilities 100000


=====================================
testsuite/tests/rts/T25560.stderr
=====================================
@@ -0,0 +1,3 @@
+T25560: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.IOException:
+
+user error (setNumCapabilities: This GHC build only supports up to 1 capabilities)


=====================================
testsuite/tests/rts/all.T
=====================================
@@ -630,3 +630,4 @@ test('T24142', [req_target_smp], compile_and_run, ['-threaded -with-rtsopts "-N2
 
 test('T25232', [unless(have_profiling(), skip), only_ways(['normal','nonmoving','nonmoving_prof','nonmoving_thr_prof']), extra_ways(['nonmoving', 'nonmoving_prof'] + (['nonmoving_thr_prof'] if have_threaded() else []))], compile_and_run, [''])
 test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_run, [''])
+test('T25560', exit_code(1), compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a568e9f9e76f2c963f579878d4e49bac7e9bcbd...b327e6af20984fed56a42b732982ee8d3e977d5f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a568e9f9e76f2c963f579878d4e49bac7e9bcbd...b327e6af20984fed56a42b732982ee8d3e977d5f
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241206/1d8c39d9/attachment-0001.html>