Only start GHC once per thread

Author: martijnbastiaan

.github/workflows/ci.yml

@@ -70,7 +70,6 @@ jobs:
           - "9.4.7"
           - "9.2.8"
           - "9.0.2"
-          - "8.10.7"
         exclude:
           # Newer macOSs don't have the right LLVM to compile our dependencies
           - os: macOS-latest

CHANGES.markdown

@@ -2,7 +2,7 @@
  * Account for `default-language` sections in Cabal files ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/85))
  * Add support for Cabal 3.14 ([#88](https://github.com/martijnbastiaan/doctest-parallel/pull/88))
  * Add parallel parsing on Linux/macOS. The GHC API is now used to call the parser directly, which allows parallel parsing. On Windows, files will be parsed sequentially still due to the GHC API locking files. ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/89))
- * Drop support for GHC 8.4, 8.6, and 8.8
+ * Drop support for GHC < 9
 
 # 0.3.1.1
  * Add support for GHC 9.12 (loosened bounds in Hackage revision)

doctest-parallel.cabal

@@ -17,8 +17,7 @@ author:         Martijn Bastiaan <martijn@hmbastiaan.nl>
 maintainer:     Martijn Bastiaan <martijn@hmbastiaan.nl>
 build-type:     Simple
 tested-with:
-    GHC == 8.10.7
-  , GHC == 9.0.2
+    GHC == 9.0.2
   , GHC == 9.2.8
   , GHC == 9.4.7
   , GHC == 9.6.3
@@ -101,7 +100,7 @@ library
     , directory
     , exceptions
     , filepath
-    , ghc >=8.2 && <9.13
+    , ghc >=9.0 && <9.13
     , ghc-exactprint
     , ghc-paths >=0.1.0.9
     , process

scripts/build_all.sh

@@ -1,7 +1,7 @@
 #!/bin/bash
 set -e
 
-GHCS=( "8.10.7" "9.0.2" "9.2.8" "9.4.8" "9.6.6" "9.8.1" "9.10.1" )
+GHCS=( "9.0.2" "9.2.8" "9.4.8" "9.6.6" "9.8.1" "9.10.1" )
 
 cabal update
 

src/Test/DocTest/Internal/Extract.hs

@@ -8,11 +8,18 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns #-}
 
-module Test.DocTest.Internal.Extract (Module(..), isEmptyModule, extract, eraseConfigLocation) where
+module Test.DocTest.Internal.Extract
+  ( Module(..)
+  , isEmptyModule
+  , extract
+  , extractIO
+  , eraseConfigLocation
+  ) where
 import           Prelude hiding (mod, concat)
 import           Control.DeepSeq (NFData, deepseq)
-import           Control.Exception
+import           Control.Exception (AsyncException, throw, throwIO, fromException)
 import           Control.Monad
+import           Control.Monad.Catch (catches, SomeException, Exception, Handler (Handler))
 import           Data.Generics (Data, extQ, mkQ, everythingBut)
 import           Data.List (partition, isPrefixOf)
 import           Data.List.Extra (trim, splitOn)
@@ -168,40 +175,43 @@ findModulePath importPaths modName = do
 -- | Parse a list of modules. Can throw an `ModuleNotFoundError` if a module's
 -- source file cannot be found. Can throw a `SourceError` if an error occurs
 -- while parsing.
-parse :: [String] -> String -> IO ParsedSource
-parse args modName = do
+parse :: String -> Ghc ParsedSource
+parse modName = do
   -- Find all specified modules on disk
-  withGhc args $ do
-    importPaths0 <- importPaths <$> getDynFlags
-    path <- liftIO $ findModulePath importPaths0 modName
-
-    -- LANGUAGE pragmas can influence how a file is parsed. For example, CPP
-    -- means we need to preprocess the file before parsing it. We use GHC's
-    -- `getOptionsFromFile` to parse these pragmas and then feed them as options
-    -- to the "real" parser.
-    dynFlags0 <- getDynFlags
+  importPaths0 <- importPaths <$> getDynFlags
+  path <- liftIO $ findModulePath importPaths0 modName
+
+  -- LANGUAGE pragmas can influence how a file is parsed. For example, CPP
+  -- means we need to preprocess the file before parsing it. We use GHC's
+  -- `getOptionsFromFile` to parse these pragmas and then feed them as options
+  -- to the "real" parser.
+  dynFlags0 <- getDynFlags
 #if __GLASGOW_HASKELL__ < 904
-    flagsFromFile <-
+  flagsFromFile <-
 #else
-    (_, flagsFromFile) <-
+  (_, flagsFromFile) <-
 #endif
-      liftIO $ getOptionsFromFile (initParserOpts dynFlags0) path
-    (dynFlags1, _, _) <- parseDynamicFilePragma dynFlags0 flagsFromFile
+    liftIO $ getOptionsFromFile (initParserOpts dynFlags0) path
+  (dynFlags1, _, _) <- parseDynamicFilePragma dynFlags0 flagsFromFile
 
 #if MIN_VERSION_ghc_exactprint(1,3,0)
-    result <- parseModuleEpAnnsWithCppInternal defaultCppOptions dynFlags1 path
+  result <- parseModuleEpAnnsWithCppInternal defaultCppOptions dynFlags1 path
 #else
-    result <- parseModuleApiAnnsWithCppInternal defaultCppOptions dynFlags1 path
+  result <- parseModuleApiAnnsWithCppInternal defaultCppOptions dynFlags1 path
 #endif
 
-    case result of
-      Left errs -> throwErrors errs
+  case result of
+    Left errs -> throwErrors errs
 #if MIN_VERSION_ghc_exactprint(1,3,0)
-      Right (_cppComments, _dynFlags, parsedSource) -> pure parsedSource
+    Right (_cppComments, _dynFlags, parsedSource) -> pure parsedSource
 #else
-      Right (_apiAnns, _cppComments, _dynFlags, parsedSource) -> pure parsedSource
+    Right (_apiAnns, _cppComments, _dynFlags, parsedSource) -> pure parsedSource
 #endif
 
+-- | Like `extract`, but runs in the `IO` monad given GHC parse arguments.
+extractIO :: [String] -> String -> IO (Module (Located String))
+extractIO parseArgs modName = withGhc parseArgs $ extract modName
+
 -- | Extract all docstrings from given list of files/modules.
 --
 -- This includes the docstrings of all local modules that are imported from
@@ -210,9 +220,9 @@ parse args modName = do
 -- Can throw `ExtractError` if an error occurs while extracting the docstrings,
 -- or a `SourceError` if an error occurs while parsing the module. Can throw a
 -- `ModuleNotFoundError` if a module's source file cannot be found.
-extract :: [String] -> String -> IO (Module (Located String))
-extract args modName = do
-  mod <- parse args modName
+extract :: String -> Ghc (Module (Located String))
+extract modName = do
+  mod <- parse modName
   let
     docs0 = extractFromModule modName mod
     docs1 = fmap convertDosLineEndings <$> docs0
@@ -223,7 +233,7 @@ extract args modName = do
       -- UserInterrupt) because all of them indicate severe conditions and
       -- should not occur during normal operation.
       Handler (\e -> throw (e :: AsyncException))
-    , Handler (throwIO . ExtractError)
+    , Handler (liftIO . throwIO . ExtractError)
     ]
 
 -- | Extract all docstrings from given module and attach the modules name.

src/Test/DocTest/Internal/Parse.hs

@@ -11,6 +11,7 @@ module Test.DocTest.Internal.Parse (
 , ExpectedLine (..)
 , LineChunk (..)
 , getDocTests
+, getDocTestsIO
 
 -- * exported for testing
 , parseInteractions
@@ -24,7 +25,9 @@ import           Data.Maybe
 import           Data.String
 
 import           Test.DocTest.Internal.Extract
+import           Test.DocTest.Internal.GhcUtil (withGhc)
 import           Test.DocTest.Internal.Location
+import GHC (Ghc)
 
 
 data DocTest = Example Expression ExpectedResult | Property Expression
@@ -47,10 +50,13 @@ type ExpectedResult = [ExpectedLine]
 
 type Interaction = (Expression, ExpectedResult)
 
+-- | Extract 'DocTest's from given module
+getDocTestsIO :: [String] -> String -> IO (Module [Located DocTest])
+getDocTestsIO parseArgs mod_ = withGhc parseArgs $ parseModule <$> extract mod_
 
 -- | Extract 'DocTest's from given module
-getDocTests :: [String] -> String -> IO (Module [Located DocTest])
-getDocTests args mod_ = parseModule <$> extract args mod_
+getDocTests :: String -> Ghc (Module [Located DocTest])
+getDocTests mod_ = parseModule <$> extract mod_
 
 -- | Convert documentation to `Example`s.
 parseModule :: Module (Located String) -> Module [Located DocTest]

src/Test/DocTest/Internal/Runner.hs

@@ -8,8 +8,9 @@ module Test.DocTest.Internal.Runner where
 import           Prelude hiding (putStr, putStrLn, error)
 
 import           Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId, MVar, newMVar)
-import           Control.Exception (SomeException, catch)
+import           Control.Exception (SomeException)
 import           Control.Monad hiding (forM_)
+import           Control.Monad.Catch (catch)
 import           Data.Foldable (forM_)
 import           Data.Function (on)
 import           Data.List (sortBy)
@@ -30,15 +31,18 @@ import           Test.DocTest.Internal.Options
   , cfgRandomizeOrder, cfgImplicitModuleImport, parseLocatedModuleOptions)
 import           Test.DocTest.Internal.Location
 import qualified Test.DocTest.Internal.Property as Property
-import           Test.DocTest.Internal.Runner.Example
-import           Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog, getThreadName)
 import           Test.DocTest.Internal.Extract (isEmptyModule)
+import           Test.DocTest.Internal.GhcUtil (withGhc)
+import           Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog, getThreadName)
+import           Test.DocTest.Internal.Runner.Example
 
 import           System.IO.CodePage (withCP65001)
 import           Control.Monad.Extra (whenM)
+import GHC (Ghc)
 
 #ifdef mingw32_HOST_OS
-import           Control.Concurrent.MVar (withMVar)
+import           Control.Concurrent.MVar (putMVar, takeMVar)
+import           Control.Monad.Catch (finally)
 #endif
 
 #if __GLASGOW_HASKELL__ < 804
@@ -101,7 +105,8 @@ runModules modConfig nThreads implicitPrelude parseArgs evalArgs modules = do
   (input, output) <-
     makeThreadPool
       (fromMaybe nCores nThreads)
-      (runModule modConfig implicitPrelude ghcLock parseArgs evalArgs)
+      parseArgs
+      (runModule modConfig implicitPrelude ghcLock evalArgs)
 
   -- Send instructions to threads
   liftIO (mapM_ (writeChan input) modules)
@@ -207,31 +212,30 @@ runModule
   -> MVar ()
   -- ^ GHC lock
   -> [String]
-  -- ^ Parse GHC arguments
-  -> [String]
   -- ^ Eval GHCi arguments
   -> Chan (ThreadId, ReportUpdate)
   -> ModuleName
-  -> IO ()
-runModule modConfig0 implicitPrelude ghcLock parseArgs evalArgs output modName = do
-  threadId <- myThreadId
+  -> Ghc ()
+runModule modConfig0 implicitPrelude ghcLock evalArgs output modName = do
+  threadId <- liftIO myThreadId
   let update r = writeChan output (threadId, r)
 
-  mod_@(Module module_ setup examples0 modArgs) <-
+  mod_@(Module module_ setup examples0 modArgs) <- do
 #ifdef mingw32_HOST_OS
     -- XXX: Cannot use multiple GHC APIs at the same time on Windows
-    withMVar ghcLock $ \() ->
+    liftIO $ takeMVar ghcLock
+    getDocTests modName `finally` liftIO (putMVar ghcLock ())
 #else
-    ghcLock `seq`
+    ghcLock `seq` getDocTests modName
 #endif
-      getDocTests parseArgs modName
-  update (UpdateModuleParsed modName (count (Module module_ setup examples0 modArgs)))
+
+  liftIO $ update (UpdateModuleParsed modName (count (Module module_ setup examples0 modArgs)))
   let modConfig2 = parseLocatedModuleOptions modName modConfig0 modArgs
 
   unless (isEmptyModule mod_) $
     case modConfig2 of
       Left (loc, flag) ->
-        update (UpdateOptionError loc flag)
+        liftIO $ update (UpdateOptionError loc flag)
 
       Right modConfig3 -> do
         let
@@ -267,7 +271,7 @@ runModule modConfig0 implicitPrelude ghcLock parseArgs evalArgs output modName =
 
 
         let logger = update . UpdateLog Debug
-        Interpreter.withInterpreter logger evalArgs $ \repl -> withCP65001 $ do
+        liftIO $ Interpreter.withInterpreter logger evalArgs $ \repl -> withCP65001 $ do
           -- Try to import this module, if it fails, something is off
           importResult <-
             case importModule of
@@ -292,7 +296,7 @@ runModule modConfig0 implicitPrelude ghcLock parseArgs evalArgs output modName =
               update (UpdateImportError module_ importResult)
 
   -- Signal main thread a module has been tested
-  update UpdateModuleDone
+  liftIO $ update UpdateModuleDone
 
 data ReportUpdate
   = UpdateSuccess FromSetup
@@ -316,18 +320,19 @@ data ReportUpdate
 
 makeThreadPool ::
   Int ->
-  (Chan (ThreadId, ReportUpdate) -> ModuleName -> IO ()) ->
+  [String] ->
+  (Chan (ThreadId, ReportUpdate) -> ModuleName -> Ghc ()) ->
   IO (Chan ModuleName, Chan (ThreadId, ReportUpdate))
-makeThreadPool nThreads mutator = do
+makeThreadPool nThreads parseArgs mutator = do
   input <- newChan
   output <- newChan
   forM_ [1..nThreads] $ \_ ->
-    forkIO $ forever $ do
-      modName <- readChan input
-      threadId <- myThreadId
+    forkIO $ withGhc parseArgs $ forever $ do
+      modName <- liftIO $ readChan input
+      threadId <- liftIO myThreadId
       catch
         (mutator output modName)
-        (\e -> writeChan output (threadId, UpdateInternalError modName e))
+        (\e -> liftIO $ writeChan output (threadId, UpdateInternalError modName e))
   return (input, output)
 
 reportModuleParsed :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Int -> Report ()

test/ExtractSpec.hs

@@ -21,7 +21,7 @@ import           System.FilePath
 
 shouldGive :: HasCallStack => (String, String) -> Module String -> Assertion
 (d, m) `shouldGive` expected = do
-  r <- fmap unLoc `fmap` extract ["-i" ++ dir] m
+  r <- fmap unLoc `fmap` extractIO ["-i" ++ dir] m
   eraseConfigLocation r `shouldBe` eraseConfigLocation expected
  where
   dir = "test/extract" </> d
@@ -65,7 +65,7 @@ spec = do
       ("setup", "Foo") `shouldGive` (mod_ "Foo"  [" foo", " bar", " baz"]){moduleSetup=Just "\n some setup code"}
 
     it "fails on invalid flags" $ do
-      extract ["--foobar"] "test/Foo.hs" `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False)
+      extractIO ["--foobar"] "test/Foo.hs" `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False)
 
   describe "extract (regression tests)" $ do
     it "works with infix operators" $ do

test/ParseSpec.hs

@@ -30,17 +30,17 @@ shouldGive action expected = map (fmap $ map unLoc) `fmap` fmap pure action `sho
 
 spec :: Spec
 spec = do
-  describe "getDocTests" $ do
+  describe "getDocTestsIO" $ do
     it "extracts properties from a module" $ do
-      getDocTests ["-itest/parse/property"] "Fib" `shouldGive` do
+      getDocTestsIO ["-itest/parse/property"] "Fib" `shouldGive` do
         module_ "Fib" $ do
           group $ do
             prop_ "foo"
             prop_ "bar"
             prop_ "baz"
 
     it "extracts examples from a module" $ do
-      getDocTests ["-itest/parse/simple"] "Fib" `shouldGive` do
+      getDocTestsIO ["-itest/parse/simple"] "Fib" `shouldGive` do
         module_ "Fib" $ do
           group $ do
             ghci "putStrLn \"foo\""
@@ -51,7 +51,7 @@ spec = do
               "baz"
 
     it "extracts examples from documentation for non-exported names" $ do
-      getDocTests ["-itest/parse/non-exported"] "Fib" `shouldGive` do
+      getDocTestsIO ["-itest/parse/non-exported"] "Fib" `shouldGive` do
         module_ "Fib" $ do
           group $ do
             ghci "putStrLn \"foo\""
@@ -62,7 +62,7 @@ spec = do
               "baz"
 
     it "extracts multiple examples from a module" $ do
-      getDocTests ["-itest/parse/multiple-examples"] "Foo" `shouldGive` do
+      getDocTestsIO ["-itest/parse/multiple-examples"] "Foo" `shouldGive` do
         module_ "Foo" $ do
           group $ do
             ghci "foo"
@@ -72,17 +72,17 @@ spec = do
               "42"
 
     it "returns an empty list, if documentation contains no examples" $ do
-      getDocTests ["-itest/parse/no-examples"] "Fib" >>= (`shouldSatisfy` isEmptyModule)
+      getDocTestsIO ["-itest/parse/no-examples"] "Fib" >>= (`shouldSatisfy` isEmptyModule)
 
     it "sets setup code to Nothing, if it does not contain any tests" $ do
-      getDocTests ["-itest/parse/setup-empty"] "Foo" `shouldGive` do
+      getDocTestsIO ["-itest/parse/setup-empty"] "Foo" `shouldGive` do
         module_ "Foo" $ do
           group $ do
             ghci "foo"
               "23"
 
     it "keeps modules that only contain setup code" $ do
-      getDocTests ["-itest/parse/setup-only"] "Foo" `shouldGive` do
+      getDocTestsIO ["-itest/parse/setup-only"] "Foo" `shouldGive` do
         tell [Module "Foo" (Just [Example "foo" ["23"]]) [] []]
 
   describe "parseInteractions (an internal function)" $ do