Limit capabilities to respect cgroups cpu quota

Changelog.md

@@ -1,5 +1,9 @@
 # Spectrometer Changelog
 
+## v2.18.0
+
+- When applicable, fossa-cli uses the cgroup CPU quota (under cfs) to determine the number of runtime threads to use. This dramatically improves runtime speed when we're running within a cpu-limited container on a large machine with many physical processors.
+
 ## v2.17.3
 
  - Monorepo: adds some optimizations to reduce the amount of file buffering in memory during a scan, resulting in less memory pressure and faster scans. ([#402](https://github.com/fossas/spectrometer/pull/402))

spectrometer.cabal

@@ -195,6 +195,7 @@ library
     Control.Carrier.StickyLogger
     Control.Carrier.TaskPool
     Control.Carrier.Threaded
+    Control.Concurrent.Extra
     Control.Effect.AtomicCounter
     Control.Effect.AtomicState
     Control.Effect.ConsoleRegion
@@ -252,8 +253,8 @@ library
     Strategy.Elixir.MixTree
     Strategy.Erlang.ConfigParser
     Strategy.Erlang.Rebar3Tree
-    Strategy.Fpm
     Strategy.Fortran.FpmToml
+    Strategy.Fpm
     Strategy.Glide
     Strategy.Go.GlideLock
     Strategy.Go.GoList
@@ -303,16 +304,19 @@ library
     Strategy.Ruby.BundleShow
     Strategy.Ruby.GemfileLock
     Strategy.Scala
-    Strategy.SwiftPM
     Strategy.Swift.PackageResolved
     Strategy.Swift.PackageSwift
     Strategy.Swift.Xcode.Pbxproj
     Strategy.Swift.Xcode.PbxprojParser
+    Strategy.SwiftPM
     Strategy.Yarn
     Strategy.Yarn.V1.YarnLock
     Strategy.Yarn.V2.Lockfile
     Strategy.Yarn.V2.Resolvers
     Strategy.Yarn.V2.YarnLock
+    System.CGroup
+    System.CGroup.CPU
+    System.CGroup.Types
     Text.URI.Builder
     Types
     VCS.Git
@@ -324,14 +328,14 @@ executable fossa
   main-is:        Main.hs
   hs-source-dirs: app/fossa
   build-depends:  spectrometer
-  ghc-options:    -threaded -with-rtsopts=-N
+  ghc-options:    -threaded
 
 executable pathfinder
   import:         lang
   main-is:        Main.hs
   hs-source-dirs: app/pathfinder
   build-depends:  spectrometer
-  ghc-options:    -threaded -with-rtsopts=-N
+  ghc-options:    -threaded
 
 test-suite unit-tests
   import:             lang
@@ -361,16 +365,16 @@ test-suite unit-tests
     Control.Carrier.DiagnosticsSpec
     Dart.PubDepsSpec
     Dart.PubSpecLockSpec
-    Discovery.ArchiveSpec
     Dart.PubSpecSpec
+    Discovery.ArchiveSpec
     Discovery.FiltersSpec
     Effect.ExecSpec
     Elixir.MixTreeSpec
     Erlang.ConfigParserSpec
     Erlang.Rebar3TreeSpec
     Extra.TextSpec
-    Fossa.API.TypesSpec
     Fortran.FpmTomlSpec
+    Fossa.API.TypesSpec
     Go.GlideLockSpec
     Go.GoListSpec
     Go.GomodSpec
@@ -407,8 +411,10 @@ test-suite unit-tests
     Ruby.GemfileLockSpec
     Swift.PackageResolvedSpec
     Swift.PackageSwiftSpec
-    Swift.Xcode.PbxprojSpec
     Swift.Xcode.PbxprojParserSpec
+    Swift.Xcode.PbxprojSpec
+    System.CGroup.CPUSpec
+    System.CGroup.TypesSpec
     Yarn.V2.LockfileSpec
     Yarn.V2.ResolversSpec
     Yarn.YarnLockV1Spec

src/App/Fossa/Main.hs

@@ -54,6 +54,7 @@ import App.Types (
  )
 import App.Util (validateDir, validateFile)
 import App.Version (fullVersionDescription)
+import Control.Concurrent.Extra (initCapabilities)
 import Control.Monad (unless, when)
 import Data.Bifunctor (first)
 import Data.Bool (bool)
@@ -140,6 +141,7 @@ mergeFileCmdConfig cmd file =
 
 appMain :: IO ()
 appMain = do
+  initCapabilities
   cmdConfig <- customExecParser mainPrefs (info (opts <**> helper) (fullDesc <> header "fossa-cli - Flexible, performant dependency analysis"))
   fileConfig <- readConfigFileIO
 

src/App/Pathfinder/Main.hs

@@ -5,12 +5,14 @@ module App.Pathfinder.Main (
 import App.Pathfinder.Scan (scanMain)
 import App.Types (BaseDir (..))
 import App.Util (validateDir)
+import Control.Concurrent.Extra (initCapabilities)
 import Data.Maybe (fromMaybe)
 import Options.Applicative
 import Path.IO
 
 appMain :: IO ()
 appMain = do
+  initCapabilities
   options <- execParser opts
 
   currentDir <- getCurrentDir

src/Control/Concurrent/Extra.hs

@@ -0,0 +1,39 @@
+module Control.Concurrent.Extra (
+  initCapabilities,
+) where
+
+import Control.Exception (SomeException)
+import Control.Exception.Extra (safeCatch)
+import GHC.Conc (getNumProcessors, setNumCapabilities)
+import System.CGroup
+
+-- | Sets the number of available capabilities via 'GHC.Conc.setNumCapabilities'
+--
+-- On most platforms, this sets the number of capabilities to the number of
+-- physical processors ('GHC.Conc.getNumProcessors').
+--
+-- When running within a cgroup on linux (most often within a container), this
+-- takes into account the available cpu quota
+initCapabilities :: IO ()
+initCapabilities =
+  initCapabilitiesFromCGroup
+    `safeCatch` (\(_ :: SomeException) -> defaultInitCapabilities)
+
+initCapabilitiesFromCGroup :: IO ()
+initCapabilitiesFromCGroup = do
+  cpuController <- resolveCPUController
+  cgroupCpuQuota <- getCPUQuota cpuController
+  case cgroupCpuQuota of
+    NoQuota -> defaultInitCapabilities
+    CPUQuota quota period -> do
+      procs <- getNumProcessors
+      let capabilities = clamp 1 procs (quota `div` period)
+      setNumCapabilities capabilities
+
+-- | Set number of capabilities to the number of available processors
+defaultInitCapabilities :: IO ()
+defaultInitCapabilities = setNumCapabilities =<< getNumProcessors
+
+-- | Clamp a value within a range
+clamp :: Int -> Int -> Int -> Int
+clamp lower upper = max lower . min upper

src/System/CGroup.hs

@@ -0,0 +1,6 @@
+module System.CGroup (
+  module X,
+) where
+
+import System.CGroup.CPU as X
+import System.CGroup.Types as X

src/System/CGroup/CPU.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module System.CGroup.CPU (
+  -- * The CPU cgroup controller
+  CPU,
+  resolveCPUController,
+
+  -- * Operations on the CPU controller
+  CPUQuota (..),
+  getCPUQuota,
+) where
+
+import Control.Monad ((<=<))
+import Path
+import System.CGroup.Types (Controller (..), resolveCGroupController)
+
+-- | The "cpu" cgroup controller
+data CPU
+
+resolveCPUController :: IO (Controller CPU)
+resolveCPUController = resolveCGroupController "cpu"
+
+-- | A CPU quota is the amount of CPU time we have relative to the scheduler period
+--
+-- For example:
+--
+-- | cpu.cfs_quota_us | cpu.cfs_period_us | description |
+-- | ---------------- | ----------------- | ----------- |
+-- |           100000 |            100000 | (1)         |
+-- |           200000 |            100000 | (2)         |
+-- |            50000 |            100000 | (3)         |
+-- |               -1 |            100000 | (4)         |
+--
+-- (1): we can use up to a single CPU core
+--
+-- (2): we can use up to two CPU cores
+--
+-- (3): the scheduler will give us a single CPU core for up to 50% of the time
+--
+-- (4): we can use all available CPU resources (there is no quota)
+data CPUQuota
+  = NoQuota
+  | -- | cpu.cfs_quota_us, cpu.cfs_period_us
+    CPUQuota Int Int
+  deriving (Eq, Ord, Show)
+
+-- | Read a CGroup configuration value from its file
+readCGroupInt :: Path b File -> IO Int
+readCGroupInt = readIO <=< (readFile . toFilePath)
+
+-- | Get the process CPU quota
+getCPUQuota :: Controller CPU -> IO CPUQuota
+getCPUQuota (Controller root) = do
+  quota <- readCGroupInt (root </> cpuQuotaPath)
+  case quota of
+    (-1) -> pure NoQuota
+    _ -> CPUQuota quota <$> readCGroupInt (root </> cpuPeriodPath)
+
+-- Path to the "cpu quota" file
+--
+-- When this file contains "-1", there is no quota set
+cpuQuotaPath :: Path Rel File
+cpuQuotaPath = $(mkRelFile "cpu.cfs_quota_us")
+
+-- Path to the "cpu period" file
+cpuPeriodPath :: Path Rel File
+cpuPeriodPath = $(mkRelFile "cpu.cfs_period_us")