[Git][ghc/ghc][wip/jsem] 3 commits: WIP: testing framework
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Thu Sep 29 15:30:05 UTC 2022
sheaf pushed to branch wip/jsem at Glasgow Haskell Compiler / GHC
Commits:
d91292f0 by sheaf at 2022-09-29T14:36:39+02:00
WIP: testing framework
- - - - -
f3ae35b2 by Matthew Pickering at 2022-09-29T14:46:07+02:00
hadrian: Use --make mode rather than -c for compiling libraries
Experiment, this will probably be faster when we have -jsem
- - - - -
9644da47 by Matthew Pickering at 2022-09-29T17:29:43+02:00
wip: jsem
- - - - -
19 changed files:
- compiler/GHC/Utils/IO/Semaphore.hs
- hadrian/cabal.project
- hadrian/hadrian.cabal
- hadrian/src/Builder.hs
- hadrian/src/Context.hs
- hadrian/src/Expression.hs
- hadrian/src/Flavour.hs
- hadrian/src/Hadrian/Oracles/Cabal/Rules.hs
- + hadrian/src/Hadrian/Semaphore.hs
- + hadrian/src/Hadrian/Semaphore/System.hs
- hadrian/src/Main.hs
- hadrian/src/Rules/Compile.hs
- hadrian/src/Rules/Library.hs
- hadrian/src/Rules/Nofib.hs
- hadrian/src/Rules/Test.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Packages.hs
- + testsuite/tests/driver/jsem/Main.hs
Changes:
=====================================
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, semWait, semTryWait
+ , semOpen, semThreadWait, semTryWait
, semGetValue, semPost, semUnlink )
import qualified System.Posix.Files as Posix
( stdFileMode )
@@ -71,6 +71,29 @@ data Semaphore =
#endif
}
+-- | Create a new semaphore with the given name and initial amount of
+-- available resources.
+--
+-- Throws an error if a semaphore by this name already exists.
+createSemaphore :: SemaphoreName -> Int -> IO Semaphore
+createSemaphore nm@(SemaphoreName sem_name) init_toks = do
+#if defined(mingw32_HOST_OS)
+ let toks = fromIntegral init_toks
+ (sem, exists) <- Win32.createSemaphore Nothing toks toks (Just sem_name)
+ when exists $
+ Win32.errorWin ("jsem: semaphore " ++ sem_name ++ " already exists")
+#else
+ let flags =
+ Posix.OpenSemFlags
+ { Posix.semCreate = True
+ , Posix.semExclusive = True }
+ sem <- Posix.semOpen sem_name flags Posix.stdFileMode init_toks
+#endif
+ return $
+ Semaphore
+ { semaphore = sem
+ , semaphoreName = nm }
+
-- | Open a semaphore with the given name.
--
-- If no such semaphore exists, throws an error.
@@ -96,7 +119,7 @@ waitOnSemaphore (Semaphore { semaphore = sem }) =
#if defined(mingw32_HOST_OS)
void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
#else
- Posix.semWait sem
+ Posix.semThreadWait sem
#endif
-- | Try to obtain a token from the semaphore, without blocking.
@@ -126,29 +149,6 @@ releaseSemaphore (Semaphore { semaphore = sem }) n =
return res
#endif
--- | Create a new semaphore with the given name and initial amount of
--- available resources.
---
--- Throws an error if a semaphore by this name already exists.
-createSemaphore :: SemaphoreName -> Int -> IO Semaphore
-createSemaphore nm@(SemaphoreName sem_name) init_toks = do
-#if defined(mingw32_HOST_OS)
- let toks = fromIntegral init_toks
- (sem, exists) <- Win32.createSemaphore Nothing toks toks (Just sem_name)
- when exists $
- Win32.errorWin ("jsem: semaphore " ++ sem_name ++ " already exists")
-#else
- let flags =
- Posix.OpenSemFlags
- { Posix.semCreate = True
- , Posix.semExclusive = True }
- sem <- Posix.semOpen sem_name flags Posix.stdFileMode init_toks
-#endif
- return $
- Semaphore
- { semaphore = sem
- , semaphoreName = nm }
-
-- | Destroy the given semaphore.
destroySemaphore :: Semaphore -> IO ()
destroySemaphore sem =
=====================================
hadrian/cabal.project
=====================================
@@ -1,4 +1,5 @@
packages: ./
+ , ../libraries/Win32
-- This essentially freezes the build plan for hadrian
index-state: 2022-09-10T18:46:55Z
=====================================
hadrian/hadrian.cabal
=====================================
@@ -67,6 +67,8 @@ executable hadrian
, Hadrian.Package
, Hadrian.Target
, Hadrian.Utilities
+ , Hadrian.Semaphore
+ , Hadrian.Semaphore.System
, Oracles.Flag
, Oracles.Flavour
, Oracles.Setting
@@ -153,6 +155,7 @@ executable hadrian
, containers >= 0.5 && < 0.7
, directory >= 1.3.1.0 && < 1.4
, extra >= 1.4.7
+ , exceptions
, filepath
, time
, mtl == 2.2.*
@@ -161,6 +164,13 @@ executable hadrian
, transformers >= 0.4 && < 0.6
, unordered-containers >= 0.2.1 && < 0.3
, text >= 1.2 && < 3
+ , time
+
+ if os(windows)
+ build-depends: Win32
+ else
+ build-depends: unix
+
ghc-options: -Wall
-Wincomplete-record-updates
-Wredundant-constraints
=====================================
hadrian/src/Builder.hs
=====================================
@@ -3,7 +3,7 @@ module Builder (
-- * Data types
ArMode (..), CcMode (..), ConfigurationInfo (..), DependencyType (..),
GhcMode (..), GhcPkgMode (..), HaddockMode (..), TestMode(..), SphinxMode (..),
- TarMode (..), GitMode (..), Builder (..), Win32TarballsMode(..),
+ TarMode (..), GitMode (..), Builder (..), Win32TarballsMode(..), MakeOrOneShot(..),
-- * Builder properties
builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilders,
@@ -41,6 +41,7 @@ import Packages
import GHC.IO.Encoding (getFileSystemEncoding)
import qualified Data.ByteString as BS
import qualified GHC.Foreign as GHC
+import Hadrian.Semaphore ( getJsemSemaphore, withSemaphore )
-- | C compiler can be used in two different modes:
-- * Compile or preprocess a source file.
@@ -61,7 +62,8 @@ instance NFData DependencyType
-- * Compile a C source file.
-- * Extract source dependencies by passing @-M@ command line argument.
-- * Link object files & static libraries into an executable.
-data GhcMode = CompileHs
+
+data GhcMode = CompileHs MakeOrOneShot
| CompileCWithGhc
| CompileCppWithGhc
| FindHsDependencies
@@ -69,10 +71,16 @@ data GhcMode = CompileHs
| ToolArgs
deriving (Eq, Generic, Show)
+data MakeOrOneShot = GhcMake | GhcOneShot deriving (Eq, Generic, Show)
+
instance Binary GhcMode
instance Hashable GhcMode
instance NFData GhcMode
+instance Binary MakeOrOneShot
+instance Hashable MakeOrOneShot
+instance NFData MakeOrOneShot
+
-- | To configure a package we need two pieces of information, which we choose
-- to record separately for convenience.
--
@@ -383,6 +391,12 @@ instance H.Builder Builder where
when (code /= ExitSuccess) $ do
fail "tests failed"
+ Ghc (CompileHs GhcMake) _ -> do
+ sem <- getJsemSemaphore
+ Exit code <- withSemaphore sem $ cmd [path] buildArgs
+ when (code /= ExitSuccess) $ do
+ fail "build failed"
+
_ -> cmd' [path] buildArgs
-- TODO: Some builders are required only on certain platforms. For example,
=====================================
hadrian/src/Context.hs
=====================================
@@ -148,7 +148,6 @@ pkgStampFile c at Context{..} = do
let extension = waySuffix way
pkgFile c "stamp-" extension
-
-- | Given a 'Context' and a 'FilePath' to a source file, compute the 'FilePath'
-- to its object file. For example:
-- * "Task.c" -> "_build/stage1/rts/Task.thr_o"
=====================================
hadrian/src/Expression.hs
=====================================
@@ -79,6 +79,13 @@ instance BuilderPredicate a => BuilderPredicate (GhcMode -> a) where
Ghc c _ -> builder (f c)
_ -> return False
+instance BuilderPredicate a => BuilderPredicate (MakeOrOneShot -> a) where
+ builder f = do
+ b <- getBuilder
+ case b of
+ Ghc (CompileHs mode) _ -> builder (f mode)
+ _ -> return False
+
instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
builder f = do
b <- getBuilder
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -112,7 +112,7 @@ werror = addArgs (builder Ghc ? notStage0 ? arg "-Werror")
-- | Build C and Haskell objects with debugging information.
enableDebugInfo :: Flavour -> Flavour
enableDebugInfo = addArgs $ notStage0 ? mconcat
- [ builder (Ghc CompileHs) ? arg "-g3"
+ [ builder (Ghc . CompileHs) ? arg "-g3"
, builder (Cc CompileC) ? arg "-g3"
, builder (Cabal Setup) ? arg "--disable-library-stripping"
, builder (Cabal Setup) ? arg "--disable-executable-stripping"
@@ -122,7 +122,7 @@ enableDebugInfo = addArgs $ notStage0 ? mconcat
enableTickyGhc :: Flavour -> Flavour
enableTickyGhc =
addArgs $ stage1 ? mconcat
- [ builder (Ghc CompileHs) ? ticky
+ [ builder (Ghc . CompileHs) ? ticky
, builder (Ghc LinkHs) ? ticky
]
where
@@ -139,7 +139,7 @@ enableTickyGhc =
enableLinting :: Flavour -> Flavour
enableLinting =
addArgs $ stage1 ? mconcat
- [ builder (Ghc CompileHs) ? lint
+ [ builder (Ghc . CompileHs) ? lint
]
where
lint = mconcat
@@ -150,7 +150,7 @@ enableLinting =
enableHaddock :: Flavour -> Flavour
enableHaddock =
addArgs $ stage1 ? mconcat
- [ builder (Ghc CompileHs) ? haddock
+ [ builder (Ghc . CompileHs) ? haddock
]
where
haddock = mconcat
@@ -171,7 +171,7 @@ splitSectionsIf pkgPredicate = addArgs $ do
osx <- expr isOsxTarget
not osx ? -- osx doesn't support split sections
pkgPredicate pkg ? -- Only apply to these packages
- builder (Ghc CompileHs) ? arg "-split-sections"
+ builder (Ghc . CompileHs) ? arg "-split-sections"
-- | Like 'splitSectionsIf', but with a fixed predicate: use
-- split sections for all packages but the GHC library.
@@ -182,7 +182,7 @@ splitSections = splitSectionsIf (/=ghc)
enableThreadSanitizer :: Flavour -> Flavour
enableThreadSanitizer = addArgs $ mconcat
- [ builder (Ghc CompileHs) ? arg "-optc-fsanitize=thread"
+ [ builder (Ghc . CompileHs) ? arg "-optc-fsanitize=thread"
, builder (Ghc CompileCWithGhc) ? (arg "-optc-fsanitize=thread" <> arg "-DTSAN_ENABLED")
, builder (Ghc LinkHs) ? arg "-optl-fsanitize=thread"
, builder (Cc CompileC) ? (arg "-fsanitize=thread" <> arg "-DTSAN_ENABLED")
@@ -225,19 +225,19 @@ disableProfiledLibs flavour =
-- recompilation.
omitPragmas :: Flavour -> Flavour
omitPragmas = addArgs
- $ notStage0 ? builder (Ghc CompileHs) ? package compiler
+ $ notStage0 ? builder (Ghc . CompileHs) ? package compiler
? arg "-fomit-interface-pragmas"
-- | Build stage2 dependencies with options to enable IPE debugging
-- information.
enableIPE :: Flavour -> Flavour
enableIPE = addArgs
- $ notStage0 ? builder (Ghc CompileHs)
+ $ notStage0 ? builder (Ghc . CompileHs)
? pure ["-finfo-table-map", "-fdistinct-constructor-tables"]
enableLateCCS :: Flavour -> Flavour
enableLateCCS = addArgs
- $ notStage0 ? builder (Ghc CompileHs)
+ $ notStage0 ? builder (Ghc . CompileHs)
? ((Profiling `wayUnit`) <$> getWay)
? arg "-fprof-late"
@@ -286,7 +286,7 @@ fullyStatic flavour =
- an executable (where their position is not at the beginning of
- the file).
-}
- , builder (Ghc CompileHs) ? pure [ "-fPIC", "-static" ]
+ , builder (Ghc . CompileHs) ? pure [ "-fPIC", "-static" ]
, builder (Ghc CompileCWithGhc) ? pure [ "-fPIC", "-optc", "-static"]
, builder (Ghc LinkHs) ? pure [ "-optl", "-static" ]
]
@@ -302,7 +302,7 @@ collectTimings =
-- that has been causing the allocation. So we want -v.
-- On the other hand, -v doesn't work with -ddump-to-file, so we need
-- -ddump-timings.
- addArgs $ notStage0 ? builder (Ghc CompileHs) ?
+ addArgs $ notStage0 ? builder (Ghc . CompileHs) ?
pure ["-ddump-to-file", "-ddump-timings", "-v"]
-- | Build ghc with debug rts (i.e. -debug) in and after this stage
@@ -513,7 +513,7 @@ builderSetting =
[ ("c", CompileCWithGhc)
, ("cpp", CompileCppWithGhc)
, ("deps", FindHsDependencies)
- , ("hs", CompileHs)
+ , ("hs", CompileHs GhcMake)
, ("link", LinkHs)
, ("toolargs", ToolArgs)
]
=====================================
hadrian/src/Hadrian/Oracles/Cabal/Rules.hs
=====================================
@@ -58,7 +58,7 @@ cabalOracle = do
putVerbose $ "| PackageConfiguration oracle: configuring "
++ quote (pkgName pkg) ++ " (" ++ show stage ++ ")..."
-- Configure the package with the GHC corresponding to the given stage
- hcPath <- builderPath (Ghc CompileHs stage)
+ hcPath <- builderPath (Ghc (CompileHs GhcMake) stage)
hcPkgPath <- builderPath (GhcPkg undefined stage)
-- N.B. the hcPath parameter of `configure` is broken when given an
-- empty ProgramDb. To work around this we manually construct an
=====================================
hadrian/src/Hadrian/Semaphore.hs
=====================================
@@ -0,0 +1,41 @@
+module Hadrian.Semaphore where
+
+import Hadrian.Semaphore.System
+import Hadrian.Utilities
+import Development.Shake
+
+data GlobalSemaphore = NoSemaphore | GlobalSemaphore FilePath Semaphore
+
+getJsemSemaphore :: Action GlobalSemaphore
+getJsemSemaphore = userSetting NoSemaphore
+
+globalSemaphore :: a -> (FilePath -> Semaphore -> a) -> GlobalSemaphore -> a
+globalSemaphore def _ NoSemaphore = def
+globalSemaphore _ f (GlobalSemaphore fp sem) = f fp sem
+
+initialiseSemaphore :: Int -> IO GlobalSemaphore
+initialiseSemaphore n = do
+ let sem_path = "hadrian_semaphore"
+ -- Can fail if the semaphore has not been created
+ --_ <- try_ $ semUnlink sem_path
+ sem <- createSemaphore (SemaphoreName sem_path) n
+ return (GlobalSemaphore sem_path sem)
+
+unlinkSemaphore :: GlobalSemaphore -> IO ()
+unlinkSemaphore NoSemaphore = return ()
+unlinkSemaphore (GlobalSemaphore _ sem) = destroySemaphore sem
+
+-- | Wrap an action which requires the semaphore with wait/post
+withSemaphore :: GlobalSemaphore -> Action a -> Action a
+withSemaphore sem act =
+ globalSemaphore act (\_ sem -> actionBracket (wait sem) (\_ -> post sem) (\_ -> act)) sem
+ where
+ wait s = do
+ n <- getSemaphoreValue s
+ liftIO $ print ("WAITING:" ++ show n)
+ waitOnSemaphore s
+ liftIO $ print "WAITED"
+
+ post s = do
+ liftIO $ print "POST"
+ releaseSemaphore s 1
=====================================
hadrian/src/Hadrian/Semaphore/System.hs
=====================================
@@ -0,0 +1,176 @@
+{-# LANGUAGE CPP #-}
+
+module Hadrian.Semaphore.System
+ ( -- * System semaphores
+ Semaphore(..), SemaphoreName(..)
+ , createSemaphore, openSemaphore
+ , waitOnSemaphore, tryWaitOnSemaphore
+ , getSemaphoreValue
+ , releaseSemaphore
+ , destroySemaphore
+
+ -- * Abstract semaphores
+ , AbstractSem(..)
+ , withAbstractSem
+ ) where
+
+import Control.Monad
+
+import qualified Control.Monad.Catch as MC
+
+#if defined(mingw32_HOST_OS)
+import qualified System.Win32.Event as Win32
+ ( waitForSingleObject, wAIT_OBJECT_0 )
+import qualified System.Win32.File as Win32
+ ( closeHandle )
+import qualified System.Win32.Process as Win32
+ ( iNFINITE )
+import qualified System.Win32.Semaphore as Win32
+ ( Semaphore(..), sEMAPHORE_ALL_ACCESS
+ , createSemaphore, openSemaphore, releaseSemaphore )
+import qualified System.Win32.Types as Win32
+ ( errorWin )
+#else
+import qualified System.Posix.Semaphore as Posix
+ ( Semaphore, OpenSemFlags(..)
+ , semOpen, semThreadWait, semTryWait
+ , semGetValue, semPost, semUnlink )
+import qualified System.Posix.Files as Posix
+ ( stdFileMode )
+#endif
+
+---------------------------------------
+-- Abstract semaphores
+
+-- | Abstraction over the operations of a semaphore,
+-- allowing usage with -jN or a jobserver.
+data AbstractSem = AbstractSem { acquireSem :: IO ()
+ , releaseSem :: IO ()
+ }
+
+withAbstractSem :: AbstractSem -> IO b -> IO b
+withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
+
+---------------------------------------
+-- System-specific semaphores
+
+newtype SemaphoreName =
+ SemaphoreName { getSemaphoreName :: String }
+ deriving Eq
+
+-- | A semaphore (POSIX or Win32).
+data Semaphore =
+ Semaphore
+ { semaphoreName :: !SemaphoreName
+ , semaphore ::
+#if defined(mingw32_HOST_OS)
+ !Win32.Semaphore
+#else
+ !Posix.Semaphore
+#endif
+ }
+
+-- | Create a new semaphore with the given name and initial amount of
+-- available resources.
+--
+-- Throws an error if a semaphore by this name already exists.
+createSemaphore :: SemaphoreName -> Int -> IO Semaphore
+createSemaphore nm@(SemaphoreName sem_name) init_toks = do
+#if defined(mingw32_HOST_OS)
+ let toks = fromIntegral init_toks
+ (sem, exists) <- Win32.createSemaphore Nothing toks toks (Just sem_name)
+ when exists $
+ Win32.errorWin ("jsem: semaphore " ++ sem_name ++ " already exists")
+#else
+ let flags =
+ Posix.OpenSemFlags
+ { Posix.semCreate = True
+ , Posix.semExclusive = True }
+ sem <- Posix.semOpen sem_name flags Posix.stdFileMode init_toks
+#endif
+ return $
+ Semaphore
+ { semaphore = sem
+ , semaphoreName = nm }
+
+-- | Open a semaphore with the given name.
+--
+-- If no such semaphore exists, throws an error.
+openSemaphore :: SemaphoreName -> IO Semaphore
+openSemaphore nm@(SemaphoreName sem_name) = do
+#if defined(mingw32_HOST_OS)
+ sem <- Win32.openSemaphore Win32.sEMAPHORE_ALL_ACCESS True sem_name
+#else
+ let
+ flags = Posix.OpenSemFlags
+ { Posix.semCreate = False
+ , Posix.semExclusive = False }
+ sem <- Posix.semOpen sem_name flags Posix.stdFileMode 0
+#endif
+ return $
+ Semaphore
+ { semaphore = sem
+ , semaphoreName = nm }
+
+-- | Indefinitely wait on a semaphore.
+waitOnSemaphore :: Semaphore -> IO ()
+waitOnSemaphore (Semaphore { semaphore = sem }) =
+#if defined(mingw32_HOST_OS)
+ void $ Win32.waitForSingleObject (Win32.semaphoreHandle sem) Win32.iNFINITE
+#else
+ Posix.semThreadWait sem
+#endif
+
+-- | Try to obtain a token from the semaphore, without blocking.
+--
+-- Immediately returns 'False' if no resources are available.
+tryWaitOnSemaphore :: Semaphore -> IO Bool
+tryWaitOnSemaphore (Semaphore { semaphore = sem }) =
+#if defined(mingw32_HOST_OS)
+ (== Win32.wAIT_OBJECT_0) <$> Win32.waitForSingleObject (Win32.semaphoreHandle sem) 0
+#else
+ Posix.semTryWait sem
+#endif
+
+-- | Release a semaphore: add @n@ to its internal counter,
+-- and return the semaphore's count before the operation.
+--
+-- NB: the returned value should only be used for debugging,
+-- not for the main jobserver logic.
+releaseSemaphore :: Semaphore -> Int -> IO Int
+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
+#endif
+
+-- | Destroy the given semaphore.
+destroySemaphore :: Semaphore -> IO ()
+destroySemaphore sem =
+#if defined(mingw32_HOST_OS)
+ Win32.closeHandle (Win32.semaphoreHandle $ semaphore sem)
+#else
+ Posix.semUnlink (getSemaphoreName $ semaphoreName sem)
+#endif
+
+-- | Query the current semaphore value (how many tokens it has available).
+getSemaphoreValue :: Semaphore -> IO Int
+getSemaphoreValue (Semaphore { semaphore = sem }) =
+#if defined(mingw32_HOST_OS)
+ do
+ wait_res <- Win32.waitForSingleObject (Win32.semaphoreHandle sem) (fromInteger 0)
+ if wait_res == Win32.wAIT_OBJECT_0
+ -- We were able to immediately acquire a resource from the semaphore:
+ -- release it immediately, thus obtaining the total number of available
+ -- resources.
+ then
+ (+1) . fromIntegral <$> Win32.releaseSemaphore sem 1
+ else
+ return 0
+#else
+ Posix.semGetValue sem
+#endif
=====================================
hadrian/src/Main.hs
=====================================
@@ -26,6 +26,7 @@ import qualified Rules.Selftest
import qualified Rules.SourceDist
import qualified Rules.Test
import qualified UserSettings
+import Hadrian.Semaphore
main :: IO ()
main = do
@@ -114,24 +115,31 @@ main = do
-- command line options (which happens in shakeArgsOptionsWith, but
-- isn't exposed to the user) to the exception handler, which uses the
-- verbosity and colour information to decide how much of the error to display.
- shake_opts_var <- newIORef options
+ shake_opts_var <- newIORef (options, NoSemaphore)
handleShakeException shake_opts_var $ shakeArgsOptionsWith options CommandLine.optDescrs $ \shake_opts _ targets -> do
- writeIORef shake_opts_var shake_opts
+ sem <- initialiseSemaphore (shakeThreads shake_opts)
+ let extra' = insertExtra sem (shakeExtra shake_opts)
+ writeIORef shake_opts_var (shake_opts, sem)
let targets' = filter (not . null) $ removeKVs targets
Environment.setupEnvironment
- return . Just $ (shake_opts, if null targets'
+ return . Just $ (shake_opts { shakeExtra = extra' }, if null targets'
then rules
else want targets' >> withoutActions rules)
-handleShakeException :: IORef ShakeOptions -> IO a -> IO a
+handleShakeException :: IORef (ShakeOptions, GlobalSemaphore) -> IO a -> IO a
handleShakeException shake_opts_var shake_run = do
args <- getArgs
-- Using withArgs here is a bit of a hack but the API doesn't allow another way
-- See https://github.com/ndmitchell/shake/issues/811
-- Passing --exception means shake throws an exception rather than
-- catching ShakeException and displaying the error itself to the user.
- catch (withArgs ("--exception" : args) $ shake_run) $ \(_e :: ShakeException) -> do
- shake_opts <- readIORef shake_opts_var
+ let cleanup_sem = do
+ (_, sem) <- readIORef shake_opts_var
+ unlinkSemaphore sem
+ let action = (withArgs ("--exception" : args) $ shake_run)
+ `finally` cleanup_sem
+ catch action $ \(_e :: ShakeException) -> do
+ (shake_opts, _) <- readIORef shake_opts_var
let
FailureColour col = lookupExtra red (shakeExtra shake_opts)
esc = if shakeColor shake_opts then escape col else id
=====================================
hadrian/src/Rules/Compile.hs
=====================================
@@ -206,21 +206,39 @@ compileHsObjectAndHi rs objpath = do
b@(BuildPath _root stage _path _o)
<- parsePath (parseBuildObject root) "<object file path parser>" objpath
let ctx = objectContext b
- way = C.way ctx
- ctxPath <- contextPath ctx
- (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
- need (src:deps)
-
- -- The .dependencies file lists indicating inputs. ghc will
- -- generally read more *.hi and *.hi-boot files (direct inputs).
- -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#haskell-object-files-and-hi-inputs)
- -- Note that this may allow too many *.hi and *.hi-boot files, but
- -- calculating the exact set of direct inputs is not feasible.
- trackAllow [ "**/*." ++ hisuf way
- , "**/*." ++ hibootsuf way
- ]
+ -- 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
+ then compileWithOneShot ctx
+ else compileWithMake ctx
- buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
+ where
+ compileWithMake ctx = do
+ -- Need the stamp file, which triggers a rebuild via make
+ stamp <- pkgStampFile ctx
+ let way = C.way ctx
+ lib_ways <- interpretInContext ctx getLibraryWays
+ -- In this situation -dynamic-too will produce both ways
+ unless (way == dynamic && vanilla `elem` lib_ways) $
+ need [stamp]
+
+ compileWithOneShot ctx = do
+ let way = C.way ctx
+ stage = C.stage ctx
+ ctxPath <- contextPath ctx
+ (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
+ need (src:deps)
+
+ -- The .dependencies file lists indicating inputs. ghc will
+ -- generally read more *.hi and *.hi-boot files (direct inputs).
+ -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#haskell-object-files-and-hi-inputs)
+ -- Note that this may allow too many *.hi and *.hi-boot files, but
+ -- calculating the exact set of direct inputs is not feasible.
+ trackAllow [ "**/*." ++ hisuf way
+ , "**/*." ++ hibootsuf way
+ ]
+
+ buildWithResources rs $ target ctx (Ghc (CompileHs GhcOneShot) stage) [src] [objpath]
compileNonHsObject :: [(Resource, Int)] -> SourceLang -> FilePath -> Action ()
compileNonHsObject rs lang path = do
@@ -232,7 +250,7 @@ compileNonHsObject rs lang path = do
builder = case lang of
C -> Ghc CompileCWithGhc
Cxx-> Ghc CompileCppWithGhc
- _ -> Ghc CompileHs
+ _ -> Ghc (CompileHs GhcOneShot)
src <- case lang of
Asm -> obj2src "S" (const False) ctx path
C -> obj2src "c" (const False) ctx path
=====================================
hadrian/src/Rules/Library.hs
=====================================
@@ -17,9 +17,9 @@ import Target
import Utilities
import Data.Time.Clock
import Rules.Generate (generatedDependencies)
+import Hadrian.Oracles.Cabal (readPackageData)
import Oracles.Flag
-
-- * Library 'Rules'
libraryRules :: Rules ()
@@ -52,6 +52,46 @@ registerStaticLib root archivePath = do
let ctx = Context stage (unsafeFindPackageByName name) w Final
need . (:[]) =<< pkgConfFile ctx
+buildPackage :: FilePath -> FilePath -> Action ()
+buildPackage root fp = do
+ l@(BuildPath _ stage _ (PkgStamp _ _ way)) <- parsePath (parseStampPath root) "<.stamp parser>" fp
+ let ctx = stampContext l
+ srcs <- hsSources ctx
+ gens <- interpretInContext ctx generatedDependencies
+
+ lib_targets <- libraryTargets True ctx
+
+ -- Write the current time into the file so the file always changes if
+ -- we restamp it because a dependency changes.
+
+ depPkgs <- packageDependencies <$> readPackageData (package ctx)
+ -- Stage packages are those we have in this stage.
+ stagePkgs <- stagePackages stage
+ -- We'll need those packages in our package database.
+ deps <- sequence [ pkgConfFile (ctx { package = pkg })
+ | pkg <- depPkgs, pkg `elem` stagePkgs ]
+ need deps
+ let needs
+ | isStage0 stage
+ = srcs ++ gens ++ lib_targets
+ | otherwise
+ = srcs ++ gens
+ need needs
+ unless (null srcs || isStage0 stage) $ do
+ build $ target ctx (Ghc (CompileHs GhcMake) stage) srcs []
+ time <- liftIO $ getCurrentTime
+ liftIO $ writeFile fp (show time)
+ ways <- interpretInContext ctx getLibraryWays
+ let hasVanilla = elem vanilla ways
+ hasDynamic = elem dynamic ways
+ support <- platformSupportsSharedLibs
+ when ((hasVanilla && hasDynamic) &&
+ support && way == vanilla) $ do
+ stamp <- (pkgStampFile (ctx { way = dynamic }))
+ liftIO $ writeFile stamp (show time)
+
+
+
-- | Build a static library ('LibA') under the given build root, whose path is
-- the second argument.
buildStaticLib :: FilePath -> FilePath -> Action ()
@@ -132,32 +172,6 @@ files etc.
-}
-buildPackage :: FilePath -> FilePath -> Action ()
-buildPackage root fp = do
- l@(BuildPath _ _ _ (PkgStamp _ _ way)) <- parsePath (parseStampPath root) "<.stamp parser>" fp
- let ctx = stampContext l
- srcs <- hsSources ctx
- gens <- interpretInContext ctx generatedDependencies
-
- lib_targets <- libraryTargets True ctx
-
- need (srcs ++ gens ++ lib_targets)
-
- -- Write the current time into the file so the file always changes if
- -- we restamp it because a dependency changes.
- time <- liftIO $ getCurrentTime
- liftIO $ writeFile fp (show time)
- ways <- interpretInContext ctx getLibraryWays
- let hasVanilla = elem vanilla ways
- hasDynamic = elem dynamic ways
- support <- platformSupportsSharedLibs
- when ((hasVanilla && hasDynamic) &&
- support && way == vanilla) $ do
- stamp <- (pkgStampFile (ctx { way = dynamic }))
- liftIO $ writeFile stamp (show time)
-
-
-
-- * Helpers
-- | Return all Haskell and non-Haskell object files for the given 'Context'.
@@ -231,6 +245,8 @@ data LibDyn = LibDyn String [Integer] Way DynLibExt deriving (Eq, Show)
-- | > HS<pkg name>-<pkg version>[_<way suffix>].o
data LibGhci = LibGhci String [Integer] Way deriving (Eq, Show)
+data PkgStamp = PkgStamp String [Integer] Way deriving (Eq, Show)
+
-- | Get the 'Context' corresponding to the build path for a given static library.
libAContext :: BuildPath LibA -> Context
libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way)) =
@@ -259,14 +275,6 @@ stampContext (BuildPath _ stage _ (PkgStamp pkgname _ way)) =
where
pkg = unsafeFindPackageByName pkgname
-data PkgStamp = PkgStamp String [Integer] Way deriving (Eq, Show)
-
-
--- | Parse a path to a ghci library to be built, making sure the path starts
--- with the given build root.
-parseStampPath :: FilePath -> Parsec.Parsec String () (BuildPath PkgStamp)
-parseStampPath root = parseBuildPath root parseStamp
-
-- | Parse a path to a registered ghc-pkg static library to be built, making
-- sure the path starts with the given build root.
@@ -290,6 +298,11 @@ parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci)
parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename
Parsec.<?> "build path for a ghci library"
+-- | Parse a path to a ghci library to be built, making sure the path starts
+-- with the given build root.
+parseStampPath :: FilePath -> Parsec.Parsec String () (BuildPath PkgStamp)
+parseStampPath root = parseBuildPath root parseStamp
+
-- | Parse a path to a dynamic library to be built, making sure the path starts
-- with the given build root.
parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn)
@@ -331,6 +344,7 @@ parseLibDynFilename ext = do
_ <- Parsec.string ("." ++ ext)
return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
+-- | Parse the filename of a static library to be built into a 'LibA' value.
parseStamp :: Parsec.Parsec String () PkgStamp
parseStamp = do
_ <- Parsec.string "stamp-"
=====================================
hadrian/src/Rules/Nofib.hs
=====================================
@@ -28,7 +28,7 @@ nofibRules = do
makePath <- builderPath (Make "nofib")
top <- topDirectory
- ghcPath <- builderPath (Ghc CompileHs Stage2)
+ ghcPath <- builderPath (Ghc (CompileHs GhcMake) Stage2)
-- some makefiles in nofib rely on a $MAKE
-- env var being defined
@@ -53,4 +53,4 @@ needNofibDeps = do
unlitPath <- programPath (vanillaContext Stage1 unlit)
mtlPath <- pkgConfFile (vanillaContext Stage1 mtl )
need [ unlitPath, mtlPath ]
- needBuilders [Ghc CompileHs Stage2]
+ needBuilders [Ghc (CompileHs GhcMake) Stage2]
=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -290,7 +290,6 @@ needTestsuitePackages stg = do
cross <- flag CrossCompiling
when (not cross) $ needIservBins stg
root <- buildRoot
- liftIO $ print stg
-- require the shims for testing stage1
when (stg == stage0InTree) $ do
-- Windows not supported as the wrapper scripts don't work on windows.. we could
=====================================
hadrian/src/Settings/Builders/Cabal.hs
=====================================
@@ -113,9 +113,9 @@ commonCabalArgs stage = do
, arg $ "${pkgroot}/../../doc/html/libraries/" ++ package_id
-- These trigger a need on each dependency, so every important to need
- -- them in parallel or it linearises the build of Ghc and GhcPkg
- , withStageds [Ghc CompileHs, GhcPkg Update, Cc CompileC, Ar Pack]
- , withBuilderArgs (Ghc CompileHs stage)
+ -- them in parallel or it linearises the build of Ghc and GhcPkg
+ , withStageds [Ghc (CompileHs GhcMake), GhcPkg Update, Cc CompileC, Ar Pack]
+ , withBuilderArgs (Ghc (CompileHs GhcMake) stage)
, withBuilderArgs (GhcPkg Update stage)
, bootPackageDatabaseArgs
, libraryArgs
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -14,6 +14,7 @@ import Rules.Libffi (libffiName)
import qualified Data.Set as Set
import System.Directory
import Data.Version.Extra
+import Hadrian.Semaphore ( getJsemSemaphore, globalSemaphore )
ghcBuilderArgs :: Args
ghcBuilderArgs = mconcat
@@ -41,28 +42,40 @@ toolArgs = do
, map ("-optP" ++) <$> getContextData cppOpts
]
+
compileAndLinkHs :: Args
-compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
+compileAndLinkHs = (builder (Ghc . CompileHs) ||^ builder (Ghc LinkHs)) ? do
ways <- getLibraryWays
useColor <- shakeColor <$> expr getShakeOptions
let hasVanilla = elem vanilla ways
hasDynamic = elem dynamic ways
mconcat [ arg "-Wall"
, arg "-Wcompat"
- , not useColor ? builder (Ghc CompileHs) ?
+ , not useColor ? builder (Ghc . CompileHs) ?
-- N.B. Target.trackArgument ignores this argument from the
-- input hash to avoid superfluous recompilation, avoiding
-- #18672.
arg "-fdiagnostics-color=never"
- , (hasVanilla && hasDynamic) ? builder (Ghc CompileHs) ?
+ , (hasVanilla && hasDynamic) ? builder (Ghc . CompileHs) ?
platformSupportsSharedLibs ? way vanilla ?
arg "-dynamic-too"
, commonGhcArgs
, ghcLinkArgs
, defaultGhcWarningsArgs
- , builder (Ghc CompileHs) ? arg "-c"
+ , builder (Ghc (CompileHs GhcOneShot)) ? mconcat [
+ arg "-c" ]
+ , builder (Ghc (CompileHs GhcMake)) ? do
+ jsem <- expr getJsemSemaphore
+ mconcat
+ ([ arg "--make"
+ , arg "-no-link"
+ ]
+ ++ globalSemaphore [] (\name _ -> [ arg "-jsem", arg name ]) jsem)
, getInputs
- , arg "-o", arg =<< getOutput ]
+ , notM (builder (Ghc (CompileHs GhcMake))) ? mconcat
+ [arg "-o", arg =<< getOutput]
+ ]
+
compileC :: Args
compileC = builder (Ghc CompileCWithGhc) ? do
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -13,7 +13,6 @@ packageArgs :: Args
packageArgs = do
stage <- getStage
path <- getBuildPath
- root <- getBuildRoot
compilerPath <- expr $ buildPath (vanillaContext stage compiler)
let -- Do not bind the result to a Boolean: this forces the configure rule
@@ -51,7 +50,13 @@ packageArgs = do
, package compiler ? mconcat
[ builder Alex ? arg "--latin1"
- , builder (Ghc CompileHs) ? mconcat
+ -- These files take a very long time to compile with -O1,
+ -- so we use -O0 for them just in Stage0 to speed up the
+ -- build but not affect Stage1+ executables
+ , builder (Ghc (CompileHs GhcOneShot)) ? inputs ["**/GHC/Hs/Instances.hs", "**/GHC/Driver/Session.hs"] ? stage0 ?
+ pure ["-O0"]
+
+ , builder (Ghc . CompileHs) ? mconcat
[ debugAssertions stage ? arg "-DDEBUG"
, inputs ["**/GHC.hs", "**/GHC/Driver/Make.hs"] ? arg "-fprof-auto"
@@ -59,12 +64,7 @@ packageArgs = do
pure ["-fno-ignore-interface-pragmas", "-fcmm-sink"]
-- Enable -haddock and -Winvalid-haddock for the compiler
, arg "-haddock"
- , notStage0 ? arg "-Winvalid-haddock"
- -- These files take a very long time to compile with -O1,
- -- so we use -O0 for them just in Stage0 to speed up the
- -- build but not affect Stage1+ executables
- , inputs ["**/GHC/Hs/Instances.hs", "**/GHC/Driver/Session.hs"] ? stage0 ?
- pure ["-O0"] ]
+ , notStage0 ? arg "-Winvalid-haddock" ]
, builder (Cabal Setup) ? mconcat
[ arg "--disable-library-for-ghci"
=====================================
testsuite/tests/driver/jsem/Main.hs
=====================================
@@ -0,0 +1,243 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Main ( main ) where
+
+-- base
+import Control.Concurrent
+ ( forkIO, threadDelay, killThread
+ , newEmptyMVar, takeMVar, putMVar )
+import Control.Monad
+ ( (>=>), forM, when )
+import Data.Foldable
+ ( fold, forM_ )
+import System.Console.GetOpt
+ ( OptDescr(..), ArgDescr(..), ArgOrder(..)
+ , getOpt )
+import System.Environment
+ ( getArgs, getExecutablePath )
+import Text.Read
+ ( readMaybe )
+
+-- ghc
+import GHC.Driver.MakeSem
+ ( runJSemAbstractSem )
+import GHC.Utils.IO.Semaphore
+ ( Semaphore, SemaphoreName(..)
+ , createSemaphore, destroySemaphore
+ , waitOnSemaphore, releaseSemaphore
+ , getSemaphoreValue
+ , AbstractSem(..), withAbstractSem
+ )
+import GHC.Utils.Logger
+ ( Logger, initLogger, logDumpMsg )
+import GHC.Utils.Outputable
+ ( ppr, empty )
+
+-- exceptions
+import Control.Monad.Catch
+ ( SomeException, onException
+ , bracket, bracket_, mask
+ , try, throwM )
+
+-- process
+import System.Process
+ ( callProcess )
+
+-- stm
+import Control.Concurrent.STM
+ ( atomically
+ , newTVarIO, readTVar, stateTVar )
+
+-- containers
+import Data.Tree
+ ( Tree(..), unfoldTree )
+
+--------------------------------------------------------------------------------
+
+withNewSem :: Logger -> Int -> SemaphoreName -> (Semaphore -> IO a) -> IO a
+withNewSem logger n nm act = bracket enter exit act
+ where
+ enter = createSemaphore nm n
+ exit sem = do
+ v <- getSemaphoreValue sem
+ logDumpMsg logger "exit" (ppr v)
+ destroySemaphore sem
+
+runWithAbstractSem :: Logger
+ -> SemaphoreName -> Maybe Int
+ -> (AbstractSem -> IO a) -> IO a
+runWithAbstractSem logger nm mb_sz act =
+ case mb_sz of
+ Nothing -> runJSemAbstractSem logger nm act
+ Just n -> withNewSem logger n nm \ sem ->
+ let
+ acquire = do
+ logDumpMsg logger "acquire {" empty
+ waitOnSemaphore sem
+ logDumpMsg logger "acquire }" empty
+ release = do
+ logDumpMsg logger "release {" empty
+ let toks_release = 1
+ toks_before <- releaseSemaphore sem toks_release
+ logDumpMsg logger "release }" (ppr $ toks_before + toks_release)
+ in act (AbstractSem { acquireSem = acquire
+ , releaseSem = release })
+
+type Job a = Tree a
+
+semChecker :: Int -> (a -> IO ()) -> IO (a -> IO (), IO ())
+semChecker n act = do
+ tv <- newTVarIO 0
+ let
+ check b msg = unless b . throwM . userError $ msg
+ woggle f = do
+ r <- atomically $ stateTVar tv $ \x -> (f x, x)
+ check (r >= 0 && r <= n) $ "semChecker:sem out of bounds:" <> show r
+
+ enter = woggle (+ 1)
+ exit = woggle (subtract 1)
+
+ check_final = readTVar tv >>= \x -> check (x == 0) $ "semChecker:check_final:" <> show x
+ pure (\a -> bracket_ enter exit (act a), atomically check_final)
+
+-- | Executes job and blocks until it completes.
+-- Throws exception on failure
+-- All threads forked are joined before return
+runJob :: AbstractSem -> (a -> IO ()) -> (Job a -> IO ()) -> Job a -> IO ()
+runJob sem act_leaf act (Node { rootLabel, subForest }) =
+ mask $ \unmask -> withAbstractSem sem $ do
+ rs <- forM subForest $ \a -> do
+ mv <- newEmptyMVar
+ tid <- forkIO $ try @_ @SomeException (unmask $ act a) >>= putMVar mv
+ pure (mv, tid)
+ let
+ workload = do
+ act_leaf rootLabel
+ forM_ rs $ \(mv,_) -> takeMVar mv >>= either throwM pure
+ unmask workload `onException` forM rs (\(_,tid) -> killThread tid)
+
+
+runJobLocal :: AbstractSem -> (a -> IO ()) -> Job a -> IO ()
+runJobLocal sem act j = runJob sem act (runJobLocal sem act) j
+
+runJobSubprocess :: Show a => Options -> AbstractSem -> (a -> IO ()) -> Job a -> IO ()
+runJobSubprocess ( Options { exeName = exe
+ , semName = sem_nm
+ , semSize = sz } )
+ sem act j0
+ = runJob sem act go j0
+ where
+ go j =
+ withAbstractSem sem $
+ callProcess exe
+ [ "-n " <> getSemaphoreName sem_nm
+ , "-s " <> show sz
+ , "-j " <> show j ]
+
+--runJobWithSem :: Int -> Semaphore -> (a -> IO ()) -> Job a -> IO ()
+--runJobWithSem semSize s act j
+-- = bracket (semChecker semSize act) (\(_,x) -> x) $ \(sem_checker,_) -> do
+-- let ab_sem = undefined s
+-- runJob s sem_checker j
+
+
+main :: IO ()
+main = do
+ opts@( Options{ semName
+ , semSize
+ , job
+ , delegate } ) <- getOptions
+
+ logger <- initLogger
+
+ (sem_checker, check_final) <- let
+ act_leaf = threadDelay
+ in semChecker semSize act_leaf
+
+ runWithAbstractSem logger semName (Just semSize) $ \sem -> do
+ let
+ go j | delegate = runJobSubprocess opts sem sem_checker j
+ | otherwise = runJobLocal sem sem_checker j
+ runJob sem sem_checker go job
+ check_final
+
+-------------------------------------------
+-- Command line argument handling.
+
+data Options = Options
+ { isLeader :: !Bool -- TODO: unused
+ , semName :: !SemaphoreName
+ , job :: !(Job Int)
+ , semSize :: !Int
+ , delegate :: !Bool
+ , exeName :: !FilePath
+ }
+
+defaultOptions :: IO Options
+defaultOptions = do
+ exe_nm <- getExecutablePath
+ pure $
+ Options
+ { isLeader = False
+ , semName = SemaphoreName "jsemsem"
+ , job = pure 1
+ , semSize = 10
+ , delegate = True
+ , exeName = exe_nm
+ }
+
+newtype OptionsBuilder =
+ OptionsBuilder { buildOptions :: Options -> IO Options }
+
+instance Semigroup OptionsBuilder where
+ OptionsBuilder x <> OptionsBuilder y = OptionsBuilder $ x >=> y
+
+instance Monoid OptionsBuilder where
+ mempty = OptionsBuilder pure
+
+setSemName :: String -> OptionsBuilder
+setSemName sem_nm = OptionsBuilder $ \ o ->
+ pure $ o { semName = SemaphoreName sem_nm }
+
+setJobToDo :: String -> OptionsBuilder
+setJobToDo job_str = OptionsBuilder $ \ o ->
+ case readMaybe job_str of
+ Nothing -> throwM $ userError $ "failed to parse job: " <> job_str
+ Just j -> pure $ o { job = j }
+
+setSemSize :: String -> OptionsBuilder
+setSemSize sz_str = OptionsBuilder $ \ o ->
+ case readMaybe sz_str of
+ Nothing -> throwM $ userError $ "failed to parse size: " <> sz_str
+ Just sz -> pure $ o { semSize = sz }
+
+topJob :: Int -> Job Int
+topJob n = unfoldTree go n where
+ go x | x <= 1 = (0, [])
+ | otherwise = (x `div` 2, take n (repeat x))
+
+topJobOptionsBuilder :: OptionsBuilder
+topJobOptionsBuilder = OptionsBuilder $ \ o ->
+ pure $ o { job = topJob 5, isLeader = True }
+
+options :: [OptDescr OptionsBuilder]
+options = [sem_name, sem_size, job, topjob]
+ where
+ sem_name = Option ['n'] ["sem-name"] (ReqArg setSemName "SEMNAME") "name of the semaphore"
+ job = Option ['j'] ["job"] (ReqArg setJobToDo "JOB" ) "job to do"
+ topjob = Option ['t'] ["topjob"] (NoArg topJobOptionsBuilder ) "default top job"
+ sem_size = Option ['s'] ["sem-size"] (ReqArg setSemSize "SEMSIZE") "number of slots in the semaphore"
+
+getOptions :: IO Options
+getOptions = do
+ args <- getArgs
+ case getOpt RequireOrder options args of
+ ([os],[],[]) -> defaultOptions >>= buildOptions os
+ (_,uos,errs) -> throwM $ userError $ fold $
+ [ "Parsing options failed:" ]
+ <> [ "unrecognised option:" <> o | o <- uos ]
+ <> [ "error: " <> e | e <- errs ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6367d03cc2a45f412bf5f8ae80e3e7669836808b...9644da47cd44eaeadb97ac0ba6ad8ae99e201983
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6367d03cc2a45f412bf5f8ae80e3e7669836808b...9644da47cd44eaeadb97ac0ba6ad8ae99e201983
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/20220929/5211aaa8/attachment-0001.html>
More information about the ghc-commits
mailing list