adjust cpu maximum clock frequency in response to cpu temperature

temp.hs

#!/usr/bin/env nix-shell
#!nix-shell -i runhaskell -p "haskellPackages.ghcWithPackages (p: [p.async p.stm p.dimensional p.asciichart p.foldl])"

{-# OPTIONS_GHC "-Wno-missing-signatures" #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-} -- Only to write down some types. Not doing anything fancy here.

import Control.Applicative
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.Except
import Data.Text.Chart
import Data.Time
import Numeric.Units.Dimensional.Prelude
import System.Directory
import System.Environment
import System.FilePath
import System.Process
import Text.Printf
import Text.Read
import qualified Control.Foldl as L
import qualified Numeric.NumType.DK.Integers as DK

writeExistingFile path content = do
    exists <- liftIO $ doesFileExist path
    when (not exists) $ do
        throwError $ printf "Missing file: %s" path

    --liftIO $ printf "writeFile %s %s\n" path content
    liftIO $ writeFile path content

parseTemp :: (Fractional a, Read a) => String -> Either String (CelsiusTemperature a)
parseTemp raw = (*~ milli degreeCelsius) <$> readEither raw

readTemp thermalZone expectedType = do
    zoneType <- liftIO $ init <$> readFile (thermalZone </> "type")
    when (zoneType /= expectedType) $ do
        throwError $ printf "Unexpected thermal zone type: %s" zoneType
    raw <- liftIO $ init <$> readFile (thermalZone </> "temp")
    liftEither $ parseTemp raw

writeMaxFreq cpufreqPolicyPaths maxFreq = do
    --liftIO $ printf "writeMaxFreq: %s\n" maxFreq
    forM_ cpufreqPolicyPaths $ \policyPath -> do
        let maxFreqPath = policyPath </> "scaling_max_freq"
        writeExistingFile maxFreqPath maxFreq

type FrequencyChange a       = Quantity ('Dim 'DK.Zero 'DK.Zero 'DK.Neg2 'DK.Zero 'DK.Zero 'DK.Zero 'DK.Zero) a
type FrequencyChangeChange a = Quantity ('Dim 'DK.Zero 'DK.Zero 'DK.Neg3 'DK.Zero 'DK.Zero 'DK.Zero 'DK.Zero) a

data Config a = Config
    { tempMax  :: CelsiusTemperature a
    , sampleDelay :: Time a
    , sampleModelPeriod :: Time a
    , sampleGraphPeriod :: Time a
    , clockMin :: Frequency a
    , clockMax :: Frequency a
    , scaleUpFactor :: Dimensionless a
    -- ^ The normally slight upward bias of the acceleration computation is
    -- multiplied by this.
    , scaleUpTime :: Time a
    -- ^ Minimum time to scale from @clockMin@ to @clockMax@, to compute
    -- @clockVelmax@.
    , cpufreqPath :: FilePath
    , thermalZonePath :: FilePath
    , expectedThermalZoneType :: String
    } deriving Show

-- | Maximum hertz-per-second to change the frequency when scaling up. Scaling
-- down is faster.
clockVelMax :: Fractional a => Config a -> FrequencyChange a
clockVelMax c = (clockMax c - clockMin c) / scaleUpTime c

-- | Amount of time represented by temperature samples.
--
-- >>> max (5 *~ minute) (60 *~ second)
-- 300 s
samplePeriod c = max (sampleModelPeriod c) (sampleGraphPeriod c)
-- | Total number of temperature samples to keep, and to use in the graphs.
--
-- >>> (5 *~ minute) / (3 *~ second)
-- 100.0
sampleCount c = round $ samplePeriod c / sampleDelay c /~ one
-- | Number of temperature samples to use in the model.
--
-- >>> (60 *~ second) / (3 *~ second)
-- 20.0
--
-- And 20 is 1/5th 100.
sampleModelCount c = round $ sampleModelPeriod c / sampleDelay c /~ one

data State a = State
    { temps    :: [CelsiusTemperature a]
    , elapsed  :: Time a
    , clock    :: Frequency a
    , clockVel :: FrequencyChange a
    , clockAcc :: FrequencyChangeChange a
    } deriving Show

tempCur :: State a -> CelsiusTemperature a
tempCur State{temps=[]} = error "No data"
tempCur State{temps=x:_} = x

tempAvg :: RealFrac a => Config a -> State a -> CelsiusTemperature a
tempAvg _c State{temps=[]} = error "No data"
tempAvg c State{temps=xs@(_:_)} = mean $ take (sampleModelCount c) xs

-- | Overage is positive when max temp is exceeded. [0..Inf)
tempOverage :: (Ord a, Num a) => Config a -> State a -> CelsiusTemperature a
tempOverage c s = max _0 (tempCur s - tempMax c)

-- | Reflects departure from recent history.
tempAbruptChange :: (RealFrac a) => Config a -> State a -> CelsiusTemperature a
tempAbruptChange c s = tempCur s - tempAvg c s

-- | Alarm distance lerps from "ok" to "oh no" over [0..1].
tempAlarmDist :: (Ord a, Fractional a) => Config a -> State a -> Dimensionless a
tempAlarmDist c s = _1 - clamp (_0, _1) closeness
  where
    closeness = tempCur s / tempMax c

clamp (minVal, maxVal) x
    | maxVal < minVal = error "Invalid clamp range"
    | otherwise = min maxVal . max minVal $ x

-- | Apply accel to velocity. Apply that velocity to the clock.
velocityModel :: (Ord a, Real a, Fractional a) => Config a -> State a -> State a
velocityModel c@Config{clockMin,clockMax} s@State{elapsed, clockAcc, clockVel, clock}
    = s { clockVel = if clock₁ <= clockMin || clockMax <= clock₁ then _0 else clockVel₁
        , clock = clock₁
        }
  where
    clock₁
        = clamp (clockMin, clockMax)
        $ clock + clockVel₁ * elapsed
    velMax = clockVelMax c
    clockVel₁
        = clamp (negate velMax * _9, velMax)
        $ clockVel + clockAcc * elapsed

-- | Velocity loses a half MHz/s every second.
frictionModel s@State{elapsed, clockVel}
    | abs clockVel < abs friction = s{clockVel = _0}
    | otherwise                   = s{clockVel = clockVel - friction}
  where
    friction = constant * elapsed
    constant = _1/_2 * signum clockVel
        /~ one
        *~ (mega hertz / (second * second))

simpleAccel :: (Ord a, Floating a, RealFrac a) => Config a -> State a -> FrequencyChangeChange a
simpleAccel c s@State{} =
    ( bias -- slight upward bias
    + negate change -- stabilize against temperature changes
    - abs overage -- ignore sign, reduce by overage
    )
    * (1 *~ (mega hertz / (second * second)))
  where
    overage = unDeg $ tempOverage c s
    change = unDeg $ tempAbruptChange c s
    bias = tempAlarmDist c s * scaleUpFactor c
    -- celsius -> dimensionless
    unDeg = (*~ one) . (/~ degreeCelsius)

model :: (Show a, RealFrac a, Floating a) => Config a -> State a -> State a
model c s = frictionModel $ velocityModel c s{clockAcc=simpleAccel c s}

ndt2dim :: Fractional a => NominalDiffTime -> Time a
ndt2dim = changeRep . (*~ second) . toRational . nominalDiffTimeToSeconds

-- | Call a function over and over with a fixed delay time between the
-- beginnings of each call.
--
-- >>> let job _ = system "date && sleep $((1 + $RANDOM % 3)) && echo job done" >> return ()
-- >>> tickThread (5 *~ second) job
tickThread :: (Fractional a, RealFrac a) => Time a -> (Time a -> IO ()) -> IO ()
tickThread delay f = do
    -- Say the previous execution was delay-seconds ago so that the first call
    -- happens immediately.
    t <- getCurrentTime
    let delaySec = secondsToNominalDiffTime $ changeRep delay /~ second
    go $ addUTCTime (-delaySec) t
  where
    go t₀ = do
        t₁ <- getCurrentTime
        let soFar = ndt2dim $ diffUTCTime t₁ t₀
            remainder = delay - soFar
        --printf "tickThread: command took %s, sleeping the remaining %s\n" (show soFar) (show remainder)
        tv <- registerDelay . truncate $ remainder /~ micro second
        atomically $ check =<< readTVar tv
        -- doot dah doot
        t₂ <- getCurrentTime
        let elapsed = ndt2dim $ diffUTCTime t₂ t₀
        --printf "tickThread: %s total elapsed\n" (show elapsed)
        f elapsed
        go t₂

initialize :: Dimensionless Double -> CelsiusTemperature Double -> ExceptT String IO (Config Double, TVar (State Double))
initialize scaleUpFactor tempMax = do
    temp <- readTemp (thermalZonePath c) (expectedThermalZoneType c)
    v <- liftIO $ newTVarIO State
        { temps = [temp]
        , elapsed = _0
        , clock = 2.4 *~ giga hertz
        , clockVel = _0
        , clockAcc = _0
        }
    return (c, v)
  where
    c = let
            sampleDelay = 2 *~ second -- ^ How much time between taking samples?
            sampleModelPeriod = 30 *~ second -- ^ How many samples should the model use?
            sampleGraphPeriod = 5 *~ minute -- ^ How many samples should the graph use?
            clockMin = 800 *~ mega hertz -- TODO: read from cpuinfo_min_freq
            clockMax = 3.7 *~ giga hertz -- TODO: read from cpuinfo_max_freq
            scaleUpTime = 3 *~ minute -- ^ How long it should take to get from a low-freq to a high-freq?
        in Config
        { tempMax
        , sampleDelay
        , sampleModelPeriod
        , sampleGraphPeriod
        , clockMin
        , clockMax
        , scaleUpFactor
        , scaleUpTime
        , cpufreqPath = "/sys/devices/system/cpu/cpufreq"
        , thermalZonePath = "/sys/class/thermal/thermal_zone2"
        , expectedThermalZoneType = "x86_pkg_temp"
        }

ownState :: a -> (a -> IO a) -> IO (IO ())
ownState s₀ f = do
    v <- newTVarIO s₀
    return $ (atomically . writeTVar v) =<< f =<< readTVarIO v

data Grapher a = NewGrapher | Grapher { minVal::a, maxVal::a, samples::[a] }

grapher v samplesCount label extract = ownState NewGrapher $ \g₀ -> do
    sample <- extract <$> readTVarIO v
    let (avg, display, g₁) = update sample g₀
    putStrLn $ printf "%s (current: %.3f, average: %.3f)" label sample avg
    opts <- maybe options (\h -> options{height=read h}) <$> lookupEnv "PLOT_HEIGHT"
    plotWith opts (fmap round display) `catch` \e -> print (e :: ErrorCall)
    return g₁
  where
    summary = (,,,) <$> L.mean <*> L.minimum <*> L.maximum <*> L.revList
    update s NewGrapher = (s, [s], Grapher s s [s])
    update s Grapher{minVal,maxVal,samples} =
        let samps = s:samples
            (avg, Just minv, Just maxv, _:_:disp) = L.fold summary $ samps ++ [maxVal,minVal]
        in (avg, minv:maxv:disp, Grapher{ minVal=minv, maxVal=maxv, samples=take samplesCount samps })
        -- NOTE: the average includes the max and min vals here; also it is a
        -- running average, not an overall average, whereas maxval and minval
        -- are overall

loop c v = do
    tempCurGraph <- grapher v (sampleCount c) "Instantaneous Temperature C" $
        (/~ degreeCelsius) . tempCur
    tempAvgGraph <- grapher v (sampleCount c) (printf "Average Temperature C over %s" (show $ sampleModelPeriod c) :: String) $
        (/~ degreeCelsius) . tempAvg c

    tempDstGraph <- grapher v (sampleCount c) "Distance from alarming %" $
        (/~ one) . (* (100 *~ one)) . tempAlarmDist c
    tempChgGraph <- grapher v (sampleCount c) "Abrupt Temperature Change ΔC" $
        (/~ degreeCelsius) . tempAbruptChange c
    tempOvrGraph <- grapher v (sampleCount c) "Temperature Overage ΔC" $
        (/~ degreeCelsius) . tempOverage c

    accKHzGraph <- grapher v (sampleCount c) "Acceleration KHz/s^2" $
        (/~ (kilo hertz / (second * second))) . clockAcc
    velKHzGraph <- grapher v (sampleCount c) (printf "Velocity KHz/s (max: %s KHz/s)" (show $ clockVelMax c /~ (kilo hertz / second)) :: String) $
        (/~ (kilo hertz / second)) . clockVel

    accMHzGraph <- grapher v (sampleCount c) "Acceleration MHz/s^2" $
        (/~ (mega hertz / (second * second))) . clockAcc
    velMHzGraph <- grapher v (sampleCount c) (printf "Velocity MHz/s (max: %s MHz/s)" (show $ clockVelMax c /~ (mega hertz / second)) :: String) $
        (/~ (mega hertz / second)) . clockVel

    clockGraph <- grapher v (sampleCount c) "CPU Max Scaling MHz" $
        (/~ mega hertz) . clock

    tickThread (sampleDelay c) $ \elapsed -> do
        readStep elapsed
        modelStep

        _ <- system "clear"
        printf "=================================================== period: %s, delay %s\n" (show $ samplePeriod c) (show $ sampleDelay c)
        tempCurGraph
        -- tempAvgGraph
        -- tempDstGraph
        -- tempChgGraph
        -- tempOvrGraph
        accMHzGraph
        velMHzGraph
        clockGraph

        writeStep

    `finally`
        writeCleanup
  where
    readStep elapsed = do
        temp <- either fail return =<< runExceptT
            (readTemp (thermalZonePath c) (expectedThermalZoneType c))
        atomically $ do
            s <- readTVar v
            writeTVar v s
                { temps = sampleCount c `take` (temp : temps s)
                , elapsed
                }

    modelStep = do
        atomically $ do
            s <- readTVar v
            writeTVar v $ model c s

    writeStep = do
        State{clock} <- atomically $ readTVar v
        writeHelper clock

    writeCleanup = do
        writeHelper $ clockMax c

    writeHelper freq = do
        let kilohertz = truncate $ freq /~ kilo hertz :: Int
        policyDirs <- fmap (cpufreqPath c </>) <$> listDirectory (cpufreqPath c)
        either fail return =<< runExceptT (writeMaxFreq policyDirs (show kilohertz))

-- | No no_turbo, yes turbo.
withTurbo = bracket_
    (write "/sys/devices/system/cpu/intel_pstate/no_turbo" "0")
    (write "/sys/devices/system/cpu/intel_pstate/no_turbo" "1")
  where
    write :: FilePath -> String -> IO ()
    write path contents
        = either fail return
        =<< runExceptT (writeExistingFile path contents)

main = do
    alarmTemp <- maybe (89 *~ degreeCelsius) ((*~ degreeCelsius) . read) <$> lookupEnv "ALARM_TEMP"
    scaleupFactor <- maybe (1 *~ one) ((*~ one) . read) <$> lookupEnv "SCALEUP_FACTOR"
    withTurbo $ do
        (c, v) <- either error id <$> runExceptT (initialize scaleupFactor alarmTemp)
        loop c v