[Git][ghc/ghc][master] 2 commits: Fix BCO creation setting caps when -j > -N
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Mar 16 16:18:09 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
c9c26cd6 by Teo Camarasu at 2023-03-16T12:17:50-04:00
Fix BCO creation setting caps when -j > -N
* Remove calls to 'setNumCapabilities' in 'createBCOs'
These calls exist to ensure that 'createBCOs' can benefit from
parallelism. But this is not the right place to call
`setNumCapabilities`. Furthermore the logic differs from that in the
driver causing the capability count to be raised and lowered at each TH
call if -j > -N.
* Remove 'BCOOpts'
No longer needed as it was only used to thread the job count down to `createBCOs`
Resolves #23049
- - - - -
5ddbf5ed by Teo Camarasu at 2023-03-16T12:17:50-04:00
Add changelog entry for #23049
- - - - -
4 changed files:
- compiler/GHC/Driver/Config.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- docs/users_guide/9.8.1-notes.rst
Changes:
=====================================
compiler/GHC/Driver/Config.hs
=====================================
@@ -2,7 +2,6 @@
module GHC.Driver.Config
( initOptCoercionOpts
, initSimpleOpts
- , initBCOOpts
, initEvalOpts
)
where
@@ -12,12 +11,8 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Core.SimpleOpt
import GHC.Core.Coercion.Opt
-import GHC.Runtime.Interpreter (BCOOpts(..))
import GHCi.Message (EvalOpts(..))
-import GHC.Conc (getNumProcessors)
-import Control.Monad.IO.Class
-
-- | Initialise coercion optimiser configuration from DynFlags
initOptCoercionOpts :: DynFlags -> OptCoercionOpts
initOptCoercionOpts dflags = OptCoercionOpts
@@ -32,16 +27,6 @@ initSimpleOpts dflags = SimpleOpts
, so_eta_red = gopt Opt_DoEtaReduction dflags
}
--- | Extract BCO options from DynFlags
-initBCOOpts :: DynFlags -> IO BCOOpts
-initBCOOpts dflags = do
- -- Serializing ResolvedBCO is expensive, so if we're in parallel mode
- -- (-j<n>) parallelise the serialization.
- n_jobs <- case parMakeCount dflags of
- Nothing -> liftIO getNumProcessors
- Just n -> return n
- return $ BCOOpts n_jobs
-
-- | Extract GHCi options from DynFlags and step
initEvalOpts :: DynFlags -> Bool -> EvalOpts
initEvalOpts dflags step =
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -43,7 +43,6 @@ import GHC.Driver.Phases
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
-import GHC.Driver.Config
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Finder
@@ -598,8 +597,7 @@ loadExpr interp hsc_env span root_ul_bco = do
nobreakarray = error "no break array"
bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco
- bco_opts <- initBCOOpts (hsc_dflags hsc_env)
- [root_hvref] <- createBCOs interp bco_opts [resolved]
+ [root_hvref] <- createBCOs interp [resolved]
fhv <- mkFinalizedHValue interp root_hvref
return (pls, fhv)
where
@@ -946,8 +944,7 @@ loadDecls interp hsc_env span cbc at CompiledByteCode{..} = do
, addr_env = plusNameEnv (addr_env le) bc_strs }
-- Link the necessary packages and linkables
- bco_opts <- initBCOOpts (hsc_dflags hsc_env)
- new_bindings <- linkSomeBCOs bco_opts interp le2 [cbc]
+ new_bindings <- linkSomeBCOs interp le2 [cbc]
nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let ce2 = extendClosureEnv (closure_env le2) nms_fhvs
!pls2 = pls { linker_env = le2 { closure_env = ce2 } }
@@ -995,7 +992,6 @@ loadModuleLinkables interp hsc_env pls linkables
let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables)
- bco_opts <- initBCOOpts (hsc_dflags hsc_env)
-- Load objects first; they can't depend on BCOs
(pls1, ok_flag) <- loadObjects interp hsc_env pls objs
@@ -1003,7 +999,7 @@ loadModuleLinkables interp hsc_env pls linkables
if failed ok_flag then
return (pls1, Failed)
else do
- pls2 <- dynLinkBCOs bco_opts interp pls1 bcos
+ pls2 <- dynLinkBCOs interp pls1 bcos
return (pls2, Succeeded)
@@ -1156,8 +1152,8 @@ rmDupLinkables already ls
********************************************************************* -}
-dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState
-dynLinkBCOs bco_opts interp pls bcos = do
+dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState
+dynLinkBCOs interp pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
@@ -1173,7 +1169,7 @@ dynLinkBCOs bco_opts interp pls bcos = do
ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)
le2 = le1 { itbl_env = ie2, addr_env = ae2 }
- names_and_refs <- linkSomeBCOs bco_opts interp le2 cbcs
+ names_and_refs <- linkSomeBCOs interp le2 cbcs
-- We only want to add the external ones to the ClosureEnv
let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -1187,8 +1183,7 @@ dynLinkBCOs bco_opts interp pls bcos = do
return $! pls1 { linker_env = le2 { closure_env = ce2 } }
-- Link a bunch of BCOs and return references to their values
-linkSomeBCOs :: BCOOpts
- -> Interp
+linkSomeBCOs :: Interp
-> LinkerEnv
-> [CompiledByteCode]
-> IO [(Name,HValueRef)]
@@ -1196,7 +1191,7 @@ linkSomeBCOs :: BCOOpts
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs bco_opts interp le mods = foldr fun do_link mods []
+linkSomeBCOs interp le mods = foldr fun do_link mods []
where
fun CompiledByteCode{..} inner accum =
case bc_breaks of
@@ -1211,7 +1206,7 @@ linkSomeBCOs bco_opts interp le mods = foldr fun do_link mods []
bco_ix = mkNameEnv (zip names [0..])
resolved <- sequence [ linkBCO interp le bco_ix breakarray bco
| (breakarray, bco) <- flat ]
- hvrefs <- createBCOs interp bco_opts resolved
+ hvrefs <- createBCOs interp resolved
return (zip names hvrefs)
-- | Useful to apply to the result of 'linkSomeBCOs'
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -11,7 +11,6 @@ module GHC.Runtime.Interpreter
( module GHC.Runtime.Interpreter.Types
-- * High-level interface to the interpreter
- , BCOOpts (..)
, evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
, resumeStmt
, abandonStmt
@@ -329,26 +328,11 @@ mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCent
mkCostCentres interp mod ccs =
interpCmd interp (MkCostCentres mod ccs)
-newtype BCOOpts = BCOOpts
- { bco_n_jobs :: Int -- ^ Number of parallel jobs doing BCO serialization
- }
-
-- | Create a set of BCOs that may be mutually recursive.
-createBCOs :: Interp -> BCOOpts -> [ResolvedBCO] -> IO [HValueRef]
-createBCOs interp opts rbcos = do
- let n_jobs = bco_n_jobs opts
- -- Serializing ResolvedBCO is expensive, so if we support doing it in parallel
- if (n_jobs == 1)
- then
- interpCmd interp (CreateBCOs [runPut (put rbcos)])
- else do
- old_caps <- getNumCapabilities
- if old_caps == n_jobs
- then void $ evaluate puts
- else bracket_ (setNumCapabilities n_jobs)
- (setNumCapabilities old_caps)
- (void $ evaluate puts)
- interpCmd interp (CreateBCOs puts)
+createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
+createBCOs interp rbcos = do
+ -- Serializing ResolvedBCO is expensive, so we do it in parallel
+ interpCmd interp (CreateBCOs puts)
where
puts = parMap doChunk (chunkList 100 rbcos)
=====================================
docs/users_guide/9.8.1-notes.rst
=====================================
@@ -32,6 +32,9 @@ Compiler
the specification described in the documentation of the `INCOHERENT` pragma. See GHC ticket
#22448 for further details.
+- Fix a bug in TH causing excessive calls to ``setNumCapabilities`` when ``-j`` is greater than ``-N``.
+ See GHC ticket #23049.
+
GHCi
~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee17001e54c3c6adccc5e3b67b629655c14da43a...5ddbf5edcb64f04b3527efcac727813080380aa6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee17001e54c3c6adccc5e3b67b629655c14da43a...5ddbf5edcb64f04b3527efcac727813080380aa6
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/20230316/f53b9301/attachment-0001.html>
More information about the ghc-commits
mailing list