avoid calling withNumCapabilities on every build

Author: pepeiborra

ghcide/src/Development/IDE/Main.hs

@@ -8,7 +8,8 @@ module Development.IDE.Main
 ,defaultMain
 ) where
 import           Control.Concurrent.Extra              (newLock, readVar,
-                                                        withLock)
+                                                        withLock,
+                                                        withNumCapabilities)
 import           Control.Exception.Safe                (Exception (displayException),
                                                         catchAny)
 import           Control.Monad.Extra                   (concatMapM, unless,
@@ -68,6 +69,7 @@ import           Development.IDE.Types.Options         (IdeGhcSession,
                                                         defaultIdeOptions,
                                                         optModifyDynFlags)
 import           Development.IDE.Types.Shake           (Key (Key))
+import           GHC.Conc                              (getNumProcessors)
 import           GHC.IO.Encoding                       (setLocaleEncoding)
 import           GHC.IO.Handle                         (hDuplicate)
 import           HIE.Bios.Cradle                       (findCradle)
@@ -86,6 +88,7 @@ import           Ide.Types                             (IdeCommand (IdeCommand),
                                                         PluginId (PluginId),
                                                         ipMap)
 import qualified Language.LSP.Server                   as LSP
+import           Numeric.Natural                       (Natural)
 import           Options.Applicative                   hiding (action)
 import qualified System.Directory.Extra                as IO
 import           System.Exit                           (ExitCode (ExitFailure),
@@ -163,6 +166,7 @@ data Arguments = Arguments
     , argsDebouncer             :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics
     , argsHandleIn              :: IO Handle
     , argsHandleOut             :: IO Handle
+    , argsThreads               :: Maybe Natural
     }
 
 instance Default Arguments where
@@ -179,6 +183,7 @@ instance Default Arguments where
         , argsDefaultHlsConfig = def
         , argsGetHieDbLoc = getHieDbLoc
         , argsDebouncer = newAsyncDebouncer
+        , argsThreads = Nothing
         , argsHandleIn = pure stdin
         , argsHandleOut = do
                 -- Move stdout to another file descriptor and duplicate stderr
@@ -221,12 +226,14 @@ defaultMain Arguments{..} = do
     inH <- argsHandleIn
     outH <- argsHandleOut
 
+    numProcessors <- getNumProcessors
+
     case argCommand of
         PrintExtensionSchema ->
             LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToVSCodeExtensionSchema argsHlsPlugins
         PrintDefaultConfig ->
             LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins
-        LSP -> do
+        LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do
             t <- offsetTime
             hPutStrLn stderr "Starting LSP server..."
             hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -11,7 +11,6 @@ module Development.IDE.Graph.Database(
     shakeProfileDatabase,
     ) where
 
-import           Control.Concurrent.Extra
 import           Data.Dynamic
 import qualified Data.HashSet                            as HashSet
 import           Data.IORef                              (readIORef)
@@ -24,9 +23,8 @@ import qualified Development.IDE.Graph.Internal.Intern   as Intern
 import           Development.IDE.Graph.Internal.Options
 import           Development.IDE.Graph.Internal.Rules
 import           Development.IDE.Graph.Internal.Types
-import           GHC.Conc
 
-data ShakeDatabase = ShakeDatabase !Int !Int [Action ()] Database
+data ShakeDatabase = ShakeDatabase !Int [Action ()] Database
 
 -- Placeholder to be the 'extra' if the user doesn't set it
 data NonExportedType = NonExportedType
@@ -39,9 +37,7 @@ shakeNewDatabase opts rules = do
     let extra = fromMaybe (toDyn NonExportedType) $ shakeExtra opts
     (theRules, actions) <- runRules extra rules
     db <- newDatabase extra theRules
-    let threads = shakeThreads opts
-    threads <- if threads /= 0 then pure threads else getNumProcessors
-    pure $ ShakeDatabase threads (length actions) actions db
+    pure $ ShakeDatabase (length actions) actions db
 
 shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])
 shakeRunDatabase = shakeRunDatabaseForKeys Nothing
@@ -67,7 +63,7 @@ shakeRunDatabaseForKeys
     -> ShakeDatabase
     -> [Action a]
     -> IO ([a], [IO ()])
-shakeRunDatabaseForKeys keysChanged (ShakeDatabase threads lenAs1 as1 db) as2 = withNumCapabilities threads $ do
+shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do
     incDatabase db
     flushDirty db
     -- record the keys changed

hls-graph/src/Development/IDE/Graph/Internal/Options.hs

@@ -2,11 +2,12 @@
 
 module Development.IDE.Graph.Internal.Options where
 
-import Data.Dynamic
-import Control.Monad.Trans.Reader
-import Development.IDE.Graph.Internal.Types
+import           Control.Monad.Trans.Reader
+import           Data.Dynamic
+import           Development.IDE.Graph.Internal.Types
 
 data ShakeOptions = ShakeOptions {
+    -- | Has no effect, kept only for api compatibility with Shake
     shakeThreads            :: Int,
     shakeFiles              :: FilePath,
     shakeExtra              :: Maybe Dynamic,