[Git][ghc/ghc][wip/jsem] what I have
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Oct 19 16:27:36 UTC 2022
Matthew Pickering pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC
Commits:
15dffa98 by Matthew Pickering at 2022-10-19T17:27:10+01:00
what I have
- - - - -
5 changed files:
- compiler/GHC/Driver/MakeSem.hs
- compiler/GHC/Utils/IO/Semaphore.hs
- hadrian/src/Hadrian/Semaphore.hs
- hadrian/src/Rules/Compile.hs
- libraries/unix
Changes:
=====================================
compiler/GHC/Driver/MakeSem.hs
=====================================
@@ -35,6 +35,7 @@ import Control.Concurrent.MVar
import Control.Concurrent.STM
import Data.Foldable
import Data.Functor
+import GHC.Stack
---------------------------------------
-- Semaphore jobserver
@@ -95,7 +96,9 @@ instance Outputable JobResources where
-- | Add one new token.
addToken :: JobResources -> JobResources
addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free })
- = jobs { tokensOwned = owned + 1, tokensFree = free + 1 }
+ = --if owned > 6 then pprPanic "addToken" (ppr jobs)
+ -- else
+ jobs { tokensOwned = owned + 1, tokensFree = free + 1 }
-- | Free one token.
addFreeToken :: JobResources -> JobResources
@@ -216,7 +219,7 @@ cleanupJobserver (Jobserver { jSemaphore = sem
when (toks_to_release > 0) do
tokens_before <- releaseSemaphore sem toks_to_release
logDumpMsg logger "cleanupJobserver }" $
- vcat [ text "released:" <+> ppr owned
+ vcat [ text "released:" <+> ppr toks_to_release
, text "semaphore count before release:" <+> ppr tokens_before ]
-- | Dispatch the available tokens acquired from the semaphore
@@ -242,7 +245,7 @@ dispatchTokens jobs@( Jobs { tokensFree = toks_free, jobsWaiting = wait } )
--
-- All modifications should go through this function to ensure the contents
-- of the 'TVar' remains in normal form.
-modifyJobResources :: TVar JobResources
+modifyJobResources :: HasCallStack => TVar JobResources
-> (JobResources -> STM (a, JobResources))
-> STM a
modifyJobResources jobs_tvar action = do
@@ -252,29 +255,33 @@ modifyJobResources jobs_tvar action = do
-- Check the invariant: if the number of free tokens has decreased,
-- there must be no pending jobs.
massertPpr (null (jobsWaiting jobs) || tokensFree jobs >= tokensFree old_jobs) $
- vcat [ text "modifyJobResources: pending jobs but fewer free tokens" ]
+ vcat [ text "modiyJobResources: pending jobs but fewer free tokens" ]
+ pprTraceM "modify" (ppr old_jobs $$ ppr jobs $$ callStackDoc)
jobs <- dispatchTokens jobs
+ pprTraceM "dispatch_modify" (ppr jobs)
writeTVar jobs_tvar jobs
return a
-- | Spawn a new thread that waits on the semaphore in order to acquire
-- an additional token.
acquireThread :: Jobserver -> IO JobserverAction
-acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar })
- = do
+acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
threadFinished_tmvar <- newEmptyTMVarIO
- tid <- forkIOWithUnmask \ unmask -> do
- wait_res <- MC.try (unmask $ waitOnSemaphore sem)
+ tid <- forkIO $ MC.mask_ $ do
+ wait_res <- MC.try (waitOnSemaphore sem)
atomically do
r <- case wait_res of
- Left (e :: MC.SomeException) -> return
- case MC.fromException e of
- Just ThreadKilled -> Nothing
- _ -> Just e
- Right () -> do
- modifyJobResources jobs_tvar \ jobs -> return ((), addToken jobs)
- return Nothing
+ Left (e :: MC.SomeException) -> do
+ pprTraceM "exc_bad_bad" (text $ show e)
+ return $ Just e
+ Right success -> do
+ if success
+ then do
+ modifyJobResources jobs_tvar \ jobs -> return ((), addToken jobs)
+ return Nothing
+ else
+ return Nothing
putTMVar threadFinished_tmvar r
return $ Acquiring { activeThread = tid
, threadFinished = threadFinished_tmvar }
@@ -289,30 +296,24 @@ releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do
<- atomically $ modifyJobResources jobs_tvar \ jobs ->
if guardRelease jobs
-- TODO: should this also debounce?
- then return (True , removeFreeToken jobs)
+ then return (True , removeOwnedToken $ removeFreeToken jobs)
else return (False, jobs)
if not still_ok_to_release
then return Idle
else do
- tid <- forkIOWithUnmask \ unmask -> do
- x <- MC.try $ unmask $ void $ do
- pprTraceM "releaseThread: about to release one token" $
- vcat []
- res <- releaseSemaphore sem 1
- pprTraceM "releaseThread: released one token" $
- vcat []
- return res
+ tid <- forkIO $ do
+ x <- MC.try $ void $ do
+ releaseSemaphore sem 1
atomically do
r <- case x of
Left (e :: MC.SomeException) -> do
+ pprTraceM "exc" (text $ show e)
modifyJobResources jobs_tvar \ jobs ->
- return ((), addFreeToken jobs)
- return case MC.fromException e of
- Just ThreadKilled -> Nothing
- _ -> Just e
+ return ((), addToken jobs)
+ return (Just e)
Right () -> do
- modifyJobResources jobs_tvar \ jobs ->
- return ((), removeOwnedToken jobs)
+-- modifyJobResources jobs_tvar \ jobs ->
+-- return ((), jobs)
-- NB: we already decremented the number of free tokens above,
-- so don't do that a second time.
return Nothing
@@ -354,8 +355,10 @@ tryRelease sjs@( Jobserver { jobs = jobs_tvar } )
, canReleaseToken = can_release_tvar } )
= do
jobs <- readTVar jobs_tvar
+ pprTraceM "try_release" (ppr jobs)
guard $ guardRelease jobs
can_release <- readTVar can_release_tvar
+ pprTraceM "try_release" (ppr can_release)
guard can_release
return do
action <- releaseThread sjs
@@ -382,6 +385,7 @@ tryNoticeIdle opts jobs_tvar jobserver_state
-> STM (IO JobserverState)
sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do
mb_ex <- takeTMVar threadFinished_tmvar
+ pprTraceM "MB_EX" (text $ show mb_ex)
for_ mb_ex MC.throwM
Jobs { tokensOwned } <- readTVar jobs_tvar
can_change_numcaps <- readTVar can_change_numcaps_tvar
@@ -404,19 +408,23 @@ tryNoticeIdle opts jobs_tvar jobserver_state
tryStopThread :: TVar JobResources
-> JobserverState
-> STM (IO JobserverState)
-tryStopThread jobs_tvar jsj = case jobserverAction jsj of
- Acquiring { activeThread = tid } -> do
- jobs <- readTVar jobs_tvar
- guard $ null (jobsWaiting jobs)
- return $ kill_thread_and_idle tid
- Releasing { activeThread = tid } -> do
- jobs <- readTVar jobs_tvar
- guard $ not (null (jobsWaiting jobs))
- return $ kill_thread_and_idle tid
- Idle -> retry
- where
- kill_thread_and_idle tid =
- killThread tid $> jsj { jobserverAction = Idle }
+tryStopThread jobs_tvar jsj = do
+ pprTraceM "TRY STOP THREAD" empty
+ case jobserverAction jsj of
+ Acquiring { activeThread = tid } -> do
+ jobs <- readTVar jobs_tvar
+ guard $ null (jobsWaiting jobs)
+ return $ kill_thread_and_idle tid
+ {-
+ Releasing { activeThread = tid } -> do
+ jobs <- readTVar jobs_tvar
+ guard $ not (null (jobsWaiting jobs))
+ return $ kill_thread_and_idle tid
+ -}
+ _ -> retry
+ where
+ kill_thread_and_idle tid =
+ killThread tid $> jsj { jobserverAction = Idle }
-- | Main jobserver loop: acquire/release resources as
-- needed for the pending jobs and available semaphore tokens.
=====================================
compiler/GHC/Utils/IO/Semaphore.hs
=====================================
@@ -34,7 +34,7 @@ import qualified System.Win32.Types as Win32
#else
import qualified System.Posix.Semaphore as Posix
( Semaphore, OpenSemFlags(..)
- , semOpen, semThreadWait, semTryWait
+ , semOpen, semWaitInterruptible, semTryWait
, semGetValue, semPost, semUnlink )
import qualified System.Posix.Files as Posix
( stdFileMode )
@@ -114,12 +114,12 @@ openSemaphore nm@(SemaphoreName sem_name) = do
, semaphoreName = nm }
-- | Indefinitely wait on a semaphore.
-waitOnSemaphore :: Semaphore -> IO ()
+waitOnSemaphore :: Semaphore -> IO Bool
waitOnSemaphore (Semaphore { semaphore = sem }) =
#if defined(mingw32_HOST_OS)
- void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
+ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
#else
- Posix.semThreadWait sem
+ Posix.semWaitInterruptible sem
#endif
-- | Try to obtain a token from the semaphore, without blocking.
@@ -138,15 +138,12 @@ tryWaitOnSemaphore (Semaphore { semaphore = sem }) =
--
-- NB: the returned value should only be used for debugging,
-- not for the main jobserver logic.
-releaseSemaphore :: Semaphore -> Int -> IO Int
+releaseSemaphore :: Semaphore -> Int -> IO ()
releaseSemaphore (Semaphore { semaphore = sem }) n =
#if defined(mingw32_HOST_OS)
fromIntegral <$> Win32.releaseSemaphore sem (fromIntegral n)
#else
- do
- res <- Posix.semGetValue sem
- replicateM_ n (Posix.semPost sem)
- return res
+ replicateM_ n (Posix.semPost sem)
#endif
-- | Destroy the given semaphore.
=====================================
hadrian/src/Hadrian/Semaphore.hs
=====================================
@@ -39,3 +39,5 @@ withSemaphore sem act =
post s = do
liftIO $ print "POST"
releaseSemaphore s 1
+ n <- getSemaphoreValue s
+ liftIO $ print ("SEM_VALUE:" ++ show n)
=====================================
hadrian/src/Rules/Compile.hs
=====================================
@@ -208,7 +208,7 @@ compileHsObjectAndHi rs objpath = do
let ctx = objectContext b
-- Ideally we want to use --make to build with stage0 but we need to use -jsem
-- to recover build-time performance so we only do it for stage1 at the moment.
- if isStage0 stage
+ if stage < Stage3
then compileWithOneShot ctx
else compileWithMake ctx
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit 2a6079a2b76adf29d3e3ff213dffe66cabcb76c3
+Subproject commit d9c0662f9184d68557a07cb26a330386254a5edc
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15dffa987cc50df6d15b66b25b7a658b4b0d1e32
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/15dffa987cc50df6d15b66b25b7a658b4b0d1e32
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/20221019/e194cba7/attachment-0001.html>
More information about the ghc-commits
mailing list