{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE BangPatterns #-}

-- |
-- Module: Censor.Runner
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Batteries-included harness support for "Censor": meter selection
-- from a command-line token, trace recording (built on
-- 'Censor.runCTWith', so it does not reimplement the driver), and
-- parameter sweeps.

module Censor.Runner (
    -- * Meter selection
    MeterChoice(..)
  , parseMeter
  , meterName
  , withMeterArg
  , splitMeterName
  , withSplitMeterArg

    -- * Recording traces
  , Trace(..)
  , record
  , thin

    -- * Sweeps
  , sweep

    -- * Verdicts and rendering
  , verdictName
  , shapeName
  , summary
  , clipText
  ) where

import Control.Exception (try)
import Control.Monad (forM)
import Data.IORef (newIORef, modifyIORef', readIORef)
import System.Exit (die)
import Text.Printf (printf)

import Censor

-- meter selection -------------------------------------------------------------

-- | A meter chosen by name. The PMU variants carry their display
--   label alongside the 'Counter'.
data MeterChoice
  = MeterWall
  | MeterPMU !Counter !String

-- | Parse a meter name: @wall@, @instructions@, @cycles@,
--   @branches@, @ref-cycles@, @task-clock@, @branch-misses@, or
--   @cache-misses@.
parseMeter :: String -> Maybe MeterChoice
parseMeter :: [Char] -> Maybe MeterChoice
parseMeter [Char]
s = case [Char]
s of
  [Char]
"wall"          -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just MeterChoice
MeterWall
  [Char]
"instructions"  -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just (Counter -> [Char] -> MeterChoice
MeterPMU Counter
InstructionsRetired [Char]
"instructions")
  [Char]
"cycles"        -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just (Counter -> [Char] -> MeterChoice
MeterPMU Counter
Cycles [Char]
"cycles")
  [Char]
"branches"      -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just (Counter -> [Char] -> MeterChoice
MeterPMU Counter
BranchesRetired [Char]
"branches")
  [Char]
"ref-cycles"    -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just (Counter -> [Char] -> MeterChoice
MeterPMU Counter
RefCycles [Char]
"ref-cycles")
  [Char]
"task-clock"    -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just (Counter -> [Char] -> MeterChoice
MeterPMU Counter
TaskClock [Char]
"task-clock")
  [Char]
"branch-misses" -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just (Counter -> [Char] -> MeterChoice
MeterPMU Counter
BranchMisses [Char]
"branch-misses")
  [Char]
"cache-misses"  -> MeterChoice -> Maybe MeterChoice
forall a. a -> Maybe a
Just (Counter -> [Char] -> MeterChoice
MeterPMU Counter
CacheMisses [Char]
"cache-misses")
  [Char]
_               -> Maybe MeterChoice
forall a. Maybe a
Nothing

-- | The display name of a chosen meter.
meterName :: MeterChoice -> String
meterName :: MeterChoice -> [Char]
meterName MeterChoice
MeterWall         = [Char]
"wall"
meterName (MeterPMU Counter
_ [Char]
name)  = [Char]
name

-- | Parse a meter token (defaulting to wall-clock when absent) and
--   run the callback with the resolved t'Meter' and its name,
--   bracketing a PMU counter for its lifetime and dying with a clear
--   message if it cannot be opened (e.g. the PMU meters off Linux, or
--   an unknown name). Handles the whole "wall everywhere, PMU
--   Linux-only, hard error otherwise" dance in one place.
withMeterArg :: Maybe String -> (String -> Meter -> IO a) -> IO a
withMeterArg :: forall a. Maybe [Char] -> ([Char] -> Meter -> IO a) -> IO a
withMeterArg Maybe [Char]
marg [Char] -> Meter -> IO a
k = do
  choice <- case Maybe [Char]
marg of
    Maybe [Char]
Nothing -> MeterChoice -> IO MeterChoice
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MeterChoice
MeterWall
    Just [Char]
s  -> case [Char] -> Maybe MeterChoice
parseMeter [Char]
s of
      Just MeterChoice
c  -> MeterChoice -> IO MeterChoice
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MeterChoice
c
      Maybe MeterChoice
Nothing -> [Char] -> IO MeterChoice
forall a. [Char] -> IO a
die ([Char] -> IO MeterChoice) -> [Char] -> IO MeterChoice
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown meter " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (expected wall|instructions|cycles|branches|ref-cycles"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"|task-clock|branch-misses|cache-misses)"
  case choice of
    MeterChoice
MeterWall         -> [Char] -> Meter -> IO a
k [Char]
"wall" Meter
wallClock
    MeterPMU Counter
cnt [Char]
name -> do
      r <- IO a -> IO (Either MeterError a)
forall e a. Exception e => IO a -> IO (Either e a)
try (Counter -> (Meter -> IO a) -> IO a
forall a. Counter -> (Meter -> IO a) -> IO a
withCounter Counter
cnt ([Char] -> Meter -> IO a
k [Char]
name))
      case r of
        Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Left MeterError
e  -> [Char] -> IO a
forall a. [Char] -> IO a
die ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" meter unavailable: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MeterError -> [Char]
forall a. Show a => a -> [Char]
show (MeterError
e :: MeterError) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MeterError -> [Char]
paranoidHint MeterError
e

-- | The split meter's name on the command line and in reports
--   (@cycles+wall@; see 'withSplitMeter').
splitMeterName :: String
splitMeterName :: [Char]
splitMeterName = [Char]
"cycles+wall"

-- | Run the callback with a t'SplitMeter', dying with a clear message
--   if the cycle counter cannot be opened, as 'withMeterArg' does.
withSplitMeterArg :: (SplitMeter -> IO a) -> IO a
withSplitMeterArg :: forall a. (SplitMeter -> IO a) -> IO a
withSplitMeterArg SplitMeter -> IO a
k = do
  r <- IO a -> IO (Either MeterError a)
forall e a. Exception e => IO a -> IO (Either e a)
try ((SplitMeter -> IO a) -> IO a
forall a. (SplitMeter -> IO a) -> IO a
withSplitMeter SplitMeter -> IO a
k)
  case r of
    Right a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Left MeterError
e  -> [Char] -> IO a
forall a. [Char] -> IO a
die ([Char] -> IO a) -> [Char] -> IO a
forall a b. (a -> b) -> a -> b
$ [Char]
splitMeterName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" meter unavailable: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MeterError -> [Char]
forall a. Show a => a -> [Char]
show (MeterError
e :: MeterError) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MeterError -> [Char]
paranoidHint MeterError
e

-- EPERM/EACCES means the kernel refused a counter that exists, which
-- for an unprivileged process is the paranoid level. task-clock
-- counts kernel time and so needs a lower one than the rest; see
-- Censor.Meter.
paranoidHint :: MeterError -> String
paranoidHint :: MeterError -> [Char]
paranoidHint (OpenFailed Int
n)
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
13 =
      [Char]
" (check kernel.perf_event_paranoid: task-clock needs 1"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" or lower, the other counters 2 or lower)"
paranoidHint MeterError
_ = [Char]
""

-- recording -------------------------------------------------------------------

-- | A recorded run: the final 'Result' plus the per-pair t'Frame'
--   trajectory.
data Trace = Trace
  { Trace -> [Char]
traceName   :: !String
  , Trace -> [Char]
traceMeter  :: !String
  , Trace -> Result
traceResult :: !Result
  , Trace -> [Frame]
traceFrames :: ![Frame]
  } deriving Int -> Trace -> [Char] -> [Char]
[Trace] -> [Char] -> [Char]
Trace -> [Char]
(Int -> Trace -> [Char] -> [Char])
-> (Trace -> [Char]) -> ([Trace] -> [Char] -> [Char]) -> Show Trace
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Trace -> [Char] -> [Char]
showsPrec :: Int -> Trace -> [Char] -> [Char]
$cshow :: Trace -> [Char]
show :: Trace -> [Char]
$cshowList :: [Trace] -> [Char] -> [Char]
showList :: [Trace] -> [Char] -> [Char]
Show

-- | Record a run, capturing every t'Frame' via 'runCTWith'. The
--   observer strictly accumulates frames; the driver is 'runCTWith'
--   itself, not a reimplementation of it.
record :: String -> String -> Meter -> Config -> Hypothesis a -> IO Trace
record :: forall a.
[Char] -> [Char] -> Meter -> Config -> Hypothesis a -> IO Trace
record [Char]
name [Char]
mname Meter
meter Config
cfg Hypothesis a
hyp = do
  ref <- [Frame] -> IO (IORef [Frame])
forall a. a -> IO (IORef a)
newIORef []
  res <- runCTWith meter cfg hyp $ \ !Frame
fr -> IORef [Frame] -> ([Frame] -> [Frame]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [Frame]
ref (Frame
fr Frame -> [Frame] -> [Frame]
forall a. a -> [a] -> [a]
:)
  frs <- readIORef ref
  pure $! Trace name mname res (reverse frs)

-- | Downsample a frame list for compact plotting: keep all of the
--   first 150 frames (the early motion), then a uniform stride, then
--   the final frame.
thin :: [Frame] -> [Frame]
thin :: [Frame] -> [Frame]
thin [Frame]
frs =
  let !m :: Int
m      = [Frame] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Frame]
frs
      !stride :: Int
stride = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
m Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
450)
      keep :: Frame -> Bool
keep Frame
fr = Frame -> Int
frPair Frame
fr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
150
             Bool -> Bool -> Bool
|| Frame -> Int
frPair Frame
fr Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
stride Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
             Bool -> Bool -> Bool
|| Frame -> Int
frPair Frame
fr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m
  in  (Frame -> Bool) -> [Frame] -> [Frame]
forall a. (a -> Bool) -> [a] -> [a]
filter Frame -> Bool
keep [Frame]
frs

-- sweeps ----------------------------------------------------------------------

-- | Run a parameterised family of hypotheses under one meter and
--   return each parameter's result: the recurring "control vs swept
--   input" pattern (a mismatch position, a length, ...).
sweep
  :: Meter -> Config -> (p -> IO (Hypothesis a)) -> [p] -> IO [(p, Result)]
sweep :: forall p a.
Meter
-> Config -> (p -> IO (Hypothesis a)) -> [p] -> IO [(p, Result)]
sweep Meter
meter Config
cfg p -> IO (Hypothesis a)
mk [p]
ps = [p] -> (p -> IO (p, Result)) -> IO [(p, Result)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [p]
ps ((p -> IO (p, Result)) -> IO [(p, Result)])
-> (p -> IO (p, Result)) -> IO [(p, Result)]
forall a b. (a -> b) -> a -> b
$ \p
p -> do
  h <- p -> IO (Hypothesis a)
mk p
p
  r <- runCT meter cfg h
  pure (p, r)

-- verdicts and rendering ------------------------------------------------------

-- | @\"REJECT\"@ or @\"PASS\"@.
verdictName :: Result -> String
verdictName :: Result -> [Char]
verdictName Reject{} = [Char]
"REJECT"
verdictName Pass{}   = [Char]
"PASS"

-- | A one-line human-readable render of a t'Result', suitable for
--   logging or embedding in a larger status line. Includes the
--   verdict, pairs consumed, evidence (peak log e-value, p-value),
--   effect interval, and clip count; on 'Reject' it also names the
--   driver channel of the hedge ('leakShape').
--
--   > REJECT after 342 pairs; driver=bulk peakLogW=18.42 p=1.0e-8
--   > effect=[-101.5,-98.4] clipped=6/342
summary :: Result -> String
summary :: Result -> [Char]
summary Result
r =
  let !effLo :: Double
effLo = (Double, Double) -> Double
forall a b. (a, b) -> a
fst (Result -> (Double, Double)
resEffect Result
r)
      !effHi :: Double
effHi = (Double, Double) -> Double
forall a b. (a, b) -> b
snd (Result -> (Double, Double)
resEffect Result
r)
      base :: [Char]
base = [Char] -> Double -> Double -> Double -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"peakLogW=%.2f effect=[%.1f,%.1f] %s"
               (Result -> Double
resPeakLogW Result
r) Double
effLo Double
effHi (Result -> [Char]
clipText Result
r)
  in  case Result
r of
        Reject{} ->
          [Char] -> Int -> [Char] -> [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"REJECT after %d pairs; driver=%s %s p=%.2g"
            (Result -> Int
resPairs Result
r) (LeakShape -> [Char]
shapeName (Result -> LeakShape
leakShape Result
r))
            ([Char]
base :: String) (Result -> Double
resPValue Result
r)
        Pass{} ->
          [Char] -> Int -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"PASS at %d pairs; %s"
            (Result -> Int
resPairs Result
r) ([Char]
base :: String)

-- | Render a t'Result'\'s clipping as one field. The tight count is
--   always shown; the wider bounds are appended only when clipping
--   actually reached them, so the common case stays as terse as it
--   was and a run whose effect interval saw truncated input says so.
--
--   > clipped=6/342
--   > clipped=129/138 (4c 44, 16c 3)
clipText :: Result -> String
clipText :: Result -> [Char]
clipText Result
r
  | Result -> Int
resClipped4 Result
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Result -> Int
resClipped16 Result
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = [Char]
tight
  | Bool
otherwise = [Char]
tight [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Int -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
" (4c %d, 16c %d)"
      (Result -> Int
resClipped4 Result
r) (Result -> Int
resClipped16 Result
r)
  where
    tight :: [Char]
tight = [Char] -> Int -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"clipped=%d/%d" (Result -> Int
resClipped Result
r) (Result -> Int
resPairs Result
r) :: String

-- | The short label for a 'LeakShape', as it appears on a case row
--   and in the @advisories@ block of the JSON report.
shapeName :: LeakShape -> String
shapeName :: LeakShape -> [Char]
shapeName LeakShape
s = case LeakShape
s of
  LeakShape
BulkShift   -> [Char]
"bulk"
  LeakShape
ShapeLeak   -> [Char]
"shape"
  LeakShape
RareOutlier -> [Char]
"tail"
  LeakShape
CdfShift    -> [Char]
"cdf"
  LeakShape
MixedShape  -> [Char]
"mixed"