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

-- |
-- Module: Censor
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Sequential constant-time testing.
--
-- Declare a t'Hypothesis' (an @IO@ action plus two input samplers);
-- 'runCT' measures paired class-A \/ class-B timings in random order,
-- streams them through an anytime-valid test, and either rejects (a
-- leak is detected) or exhausts its budget. Type-I error is
-- controlled at 'cfgAlpha' whenever the run stops.
--
-- = The null
--
-- The null is /conditional exchangeability/ of the measured pair
-- @(ta, tb)@: given the past, swapping the class labels leaves the
-- joint law unchanged. The randomised per-pair order supplies it,
-- provided the nuisance dynamics within a pair (cache and predictor
-- state, frequency) are blind to the class labels; randomisation
-- cannot undo a nuisance process that reacts to the class itself.
--
-- = The test
--
-- Every component bets on an /antisymmetric functional/ of the pair
-- (@g(ta, tb) = -g(tb, ta)@), which is conditionally symmetric about
-- zero under the null. The test is a uniform mixture of e-processes
-- ("Numeric.Eproc.Mixture") over a family of them, with
-- @d = ta - tb@:
--
--   * /sign/: @sign d@. Catches an asymmetry of @d@ itself,
--     including bulk shifts that heavy tails hide from the
--     magnitude components.
--   * /magnitude/: @d@ clipped to @[-c, c]@, @[-4c, 4c]@, and
--     @[-16c, 16c]@, for a warmup-estimated @c@. The tight bound is
--     the most powerful against small consistent shifts; the wide
--     ones keep rare outliers.
--   * /CDF/: @1[ta <= q] - 1[tb <= q]@ at warmup-fixed cut points
--     @q@. Catches dispersion leaks, which leave @d@ symmetric.
--
-- The family is finite, so the test is not exhaustive: a departure
-- that moves none of these functionals off zero passes. Read a
-- 'Pass' as \"no evidence on these channels\", not as proof of
-- constant time.

module Censor (
    -- * Hypothesis
    Hypothesis(..)
  , fixVsRandom
  , fixVsRandomCtx

    -- * Configuration
  , Config(..)
  , defaultConfig

    -- * Result
  , Result(..)
  , resPeakCdf

    -- * Advisories
  , Advisory(..)
  , ClipRates(..)
  , LeakShape(..)
  , diagnose
  , leakShape

    -- * Errors
  , CensorError(..)

    -- * Running
  , runCT
  , runCTWith
  , Frame(..)
  , runCTAttributed

    -- * Split runs
  , Split(..)
  , runSplit
  , runSplitWith
  , attributeSplit

    -- * Batch calibration
  , calibrateBatch
  , CalibReport(..)
  , calibrateBatchReport
  , Noise(..)

    -- * Baseline probe
  , baselineReading

    -- * A\/A and B\/B negative controls
  , toAA
  , runAA
  , toBB
  , runBB
  , Attribution(..)
  , ControlVerdict(..)
  , attribute

    -- * Measurement (re-exports)
  , Meter(..)
  , wallClock
  , Counter(..)
  , MeterError(..)
  , withCounter
  , SplitMeter(..)
  , withSplitMeter

    -- * Sampler support (re-exports)
  , Rng
  , mkRng
  , nextWord
  , reseed
  , randomBytes
  ) where

import Control.Exception (Exception, IOException, throwIO, try)
import Control.Monad (unless)
import qualified Data.Bits as B
import qualified Data.ByteString as BS
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (sort, sortBy)
import Data.Primitive.SmallArray
  (SmallArray, indexSmallArray, smallArrayFromListN)
import Data.Word (Word64)
import GHC.Clock (getMonotonicTimeNSec)
import System.IO (IOMode(ReadMode), withBinaryFile)
import qualified Numeric.Eproc.Bernoulli.TwoSided as EPSign
import qualified Numeric.Eproc.Bounded as EPMagn
import qualified Numeric.Eproc.ConfSeq as EPCS
import qualified Numeric.Eproc.Mixture as EPMix
import Numeric.Eproc.Bounded (Bettor(Newton), ConfigError)

import Censor.Meter
import Censor.Rng
  (Rng, mkRng, nextWord, randomBytes, reseed, splitMix)

-- | A constant-time hypothesis.
--
--   * @target@: the @IO@ action under test.
--   * @prepare@: a per-pair prologue, run before either sampler and
--     outside the timed region; @pure ()@ unless the classes share
--     per-pair state (see 'fixVsRandomCtx').
--   * @sampleA@, @sampleB@: samplers for the two input classes,
--     typically \"fixed\" and \"random\".
--
--   Only @target@ is timed, so any asymmetry in how the samplers
--   prepare inputs shows up as a class difference. Return inputs in
--   normal form, build the fixed class by the same code path as the
--   random one (not as a top-level constant), and keep the samplers
--   symmetric in allocation and in where the secret is read from.
--   'fixVsRandom' does this for the usual case.
data Hypothesis a = Hypothesis
  { forall a. Hypothesis a -> a -> IO ()
target  :: !(a -> IO ())
  , forall a. Hypothesis a -> IO ()
prepare :: !(IO ())
  , forall a. Hypothesis a -> IO a
sampleA :: !(IO a)
  , forall a. Hypothesis a -> IO a
sampleB :: !(IO a)
  }

-- | A dudect-style /fix-vs-random/ t'Hypothesis', from a target, a
--   secret sampler, a re-materialisation function, and a completion
--   building a full input around a secret.
--
--   The fixed secret is drawn once from the sampler, so it is an
--   ordinary heap value like the random class's. Each sample, class
--   A draws and discards a fresh secret and class B keeps its draw,
--   so the samplers allocate alike. Both classes then re-materialise
--   the pinned secret: class A completes around the copy, class B
--   discards it. With a real copy (for a 'BS.ByteString',
--   @\\s -> evaluate (BS.copy s)@), neither class is alone in reading
--   one long-lived, cache-hot value, a locality asymmetry that the
--   A\/A and B\/B controls cannot see. Pass 'pure' only for types
--   with no cheap copy.
--
--   The completion runs identically in both classes, so per-pair
--   public inputs stay fresh on both sides. The sampler,
--   re-materialiser, and completion must return values in normal
--   form.
--
--   > hyp <- fixVsRandom
--   >   (\x -> () <$ evaluate (inv x))   -- target
--   >   (randomMont g)                   -- secret sampler
--   >   pure                             -- no re-materialiser
--   >   pure                             -- input is just the secret
fixVsRandom
  :: (a -> IO ())   -- ^ target
  -> IO s           -- ^ secret sampler
  -> (s -> IO s)    -- ^ re-materialise a secret into a fresh value
  -> (s -> IO a)    -- ^ complete an input around a secret
  -> IO (Hypothesis a)
fixVsRandom :: forall a s.
(a -> IO ())
-> IO s -> (s -> IO s) -> (s -> IO a) -> IO (Hypothesis a)
fixVsRandom a -> IO ()
tgt IO s
sec s -> IO s
dup s -> IO a
embed = do
  !fix <- IO s
sec
  pure Hypothesis
    { target  = tgt
    , prepare = pure ()
    , sampleA = do
        !_ <- sec        -- draw and discard: balance class B
        !s <- dup fix
        embed s
    , sampleB = do
        !s <- sec
        !_ <- dup fix    -- copy and discard: balance class A
        embed s
    }

-- | A /fix-vs-random/ t'Hypothesis' whose two classes share one
--   freshly drawn public context per pair.
--
--   'fixVsRandom' completes each class independently, so per-pair
--   public inputs (message, nonce, modulus) either differ across the
--   pair, adding nuisance variance to @d@, or are pinned for the
--   whole run, testing a single public input. Here 'prepare' draws
--   one context per pair and both classes are built around it, so
--   the test is of secret dependence given identical fresh public
--   input. The null is unaffected: given the context, the two
--   readings are still exchangeable under H_0.
--
--   The re-materialisation function plays the same role as in
--   'fixVsRandom'.
--
--   > hyp <- fixVsRandomCtx
--   >   (\(k, m) -> () <$ evaluate (mac k m))  -- target
--   >   (randomBytes g 32)                     -- secret sampler
--   >   (\k -> evaluate (BS.copy k))           -- re-materialise
--   >   (randomBytes g 256)                    -- public context
--   >   (\msg key -> pure (key, msg))          -- build the input
fixVsRandomCtx
  :: (a -> IO ())      -- ^ target
  -> IO s              -- ^ secret sampler
  -> (s -> IO s)       -- ^ re-materialise a secret into a fresh value
  -> IO c              -- ^ public-context sampler (once per pair)
  -> (c -> s -> IO a)  -- ^ build an input from context and secret
  -> IO (Hypothesis a)
fixVsRandomCtx :: forall a s c.
(a -> IO ())
-> IO s
-> (s -> IO s)
-> IO c
-> (c -> s -> IO a)
-> IO (Hypothesis a)
fixVsRandomCtx a -> IO ()
tgt IO s
sec s -> IO s
dup IO c
ctx c -> s -> IO a
embed = do
  !fix <- IO s
sec
  -- seeded with a real draw so the ref is total; 'prepare'
  -- overwrites it before the first pair is ever measured.
  !c0  <- ctx
  ref  <- newIORef c0
  pure Hypothesis
    { target  = tgt
    , prepare = do
        !c <- ctx
        writeIORef ref c
    , sampleA = do
        !_ <- sec        -- draw and discard: balance class B
        !s <- dup fix
        !c <- readIORef ref
        embed c s
    , sampleB = do
        !s <- sec
        !_ <- dup fix    -- copy and discard: balance class A
        !c <- readIORef ref
        embed c s
    }

-- | Driver configuration.
data Config = Config
  { Config -> Double
cfgAlpha  :: !Double
    -- ^ significance level.
  , Config -> Int
cfgBudget :: !Int
    -- ^ maximum sample pairs to consume.
  , Config -> Int
cfgBatch  :: !Int
    -- ^ target repetitions per timed region, all on one pre-drawn
    --   sample. This multiplies real work only when each repetition
    --   recomputes (an FFI call, mutable state). For a pure target
    --   @\\a -> evaluate (f a)@ the thunk is forced once and the rest
    --   are no-ops, so use @1@, and widen the work if it is
    --   sub-quantum.
  , Config -> Int
cfgWarmup :: !Int
    -- ^ warmup pairs, from which the clip bound @c@ (twice the
    --   @~p99@ of @|d|@) and the CDF cut points are fixed. At @100@
    --   or fewer, the @p99@ is the sample maximum.
  , Config -> Maybe Word64
cfgSeed   :: !(Maybe Word64)
    -- ^ seed for the per-pair A\/B order bit. 'Nothing' (the
    --   default) draws one from @\/dev\/urandom@, falling back to the
    --   monotonic clock if that is unreadable. The seed used is
    --   reported as 'resSeed' for replay. Keep it independent of any
    --   sampler seed: the null needs the order bit independent of the
    --   timings.
  , Config -> Maybe Double
cfgMargin :: !(Maybe Double)
    -- ^ relative interval-null margin. 'Nothing' (the default) tests
    --   the sharp null. @Just m@ resolves at warmup to an absolute
    --   margin @delta = m * median@ of the pooled per-batch readings
    --   and tests @|E d_clipped| <= delta@: the magnitude components
    --   become interval-null tests and alone gate the verdict, while
    --   the sign and CDF components still report peaks as
    --   diagnostics. Relative, because the channels that motivate it
    --   (frequency, interrupts, scheduling) scale with the
    --   timed-region duration. Meant for the wall meter on
    --   frequency-scaled hosts (see the README); keep it 'Nothing'
    --   under the PMU meters. The resolved margin must land in
    --   @(0, c)@, else the run throws 'InvalidConfig'; it is reported
    --   as 'resMargin'.
  } deriving Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show

-- | Defaults: @alpha = 1e-6@, budget @100000@ pairs, batch 1 (no
--   inner repetition), warmup 200 pairs, order-bit seed drawn from
--   OS entropy per run, no margin (sharp null).
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config
  { cfgAlpha :: Double
cfgAlpha  = Double
1.0e-6
  , cfgBudget :: Int
cfgBudget = Int
100000
  , cfgBatch :: Int
cfgBatch  = Int
1
  , cfgWarmup :: Int
cfgWarmup = Int
200
  , cfgSeed :: Maybe Word64
cfgSeed   = Maybe Word64
forall a. Maybe a
Nothing
  , cfgMargin :: Maybe Double
cfgMargin = Maybe Double
forall a. Maybe a
Nothing
  }

-- | Test outcome: 'Reject' (a leak was detected) or 'Pass' (none
--   within budget), each carrying the same run report.
--
--   Evidence is on the log e-value scale: a run starts at @0@ and
--   rejects when the mixture's running supremum ('resPeakLogW')
--   crosses @log(1 \/ alpha)@. The per-component peaks say which
--   channel found the evidence. They are diagnostic only: each is a
--   supremum at its own time, and the verdict latches on the
--   mixture.
data Result
  = Reject
      { Result -> Int
resPairs      :: {-# UNPACK #-} !Int
        -- ^ sample pairs consumed.
      , Result -> Double
resPeakLogW   :: {-# UNPACK #-} !Double
        -- ^ peak (supremum-so-far) log e-value of the mixture;
        --   starts at @0@, crosses @log(1 \/ alpha)@ on rejection.
      , Result -> Double
resPValue     :: {-# UNPACK #-} !Double
        -- ^ the anytime-valid p-value @min 1 (exp -resPeakLogW)@;
        --   at or below 'cfgAlpha' iff the verdict is 'Reject'.
      , Result -> (Double, Double)
resEffect     :: !(Double, Double)
        -- ^ anytime-valid @1 - cfgAlpha@ confidence interval for the
        --   mean of @d@ clipped to @[-16c, 16c]@, in meter units per
        --   batch. Covers zero on a constant-time target. It can still
        --   be wide after an early 'Reject': detection outpaces
        --   estimation. Once the evidence pins the mean below the
        --   estimation grid's resolution, the last resolvable interval
        --   is reported. 'resClipped16' says how often the clipping
        --   bit.
      , Result -> Int
resClipped    :: {-# UNPACK #-} !Int
        -- ^ pairs whose @|d|@ exceeded 'resBound' and was clipped for
        --   the tight magnitude component. A large share of
        --   'resPairs' means the bound was too tight: raise
        --   'cfgWarmup' or 'cfgBatch'.
      , Result -> Int
resClipped4   :: {-# UNPACK #-} !Int
        -- ^ pairs whose @|d|@ exceeded @4 * 'resBound'@.
      , Result -> Int
resClipped16  :: {-# UNPACK #-} !Int
        -- ^ pairs whose @|d|@ exceeded @16 * 'resBound'@, the bound
        --   behind the widest magnitude component and 'resEffect'.
      , Result -> Double
resBound      :: {-# UNPACK #-} !Double
        -- ^ the tight clip bound @c@ estimated during warmup
        --   (@max 1 (2 * p99(|d|))@).
      , Result -> Double
resPeakSign   :: {-# UNPACK #-} !Double
        -- ^ peak log e-value of the sign component.
      , Result -> Double
resPeakMagn   :: {-# UNPACK #-} !Double
        -- ^ peak log e-value of the magnitude component at @c@.
      , Result -> Double
resPeakMagn4  :: {-# UNPACK #-} !Double
        -- ^ peak log e-value of the magnitude component at @4c@.
      , Result -> Double
resPeakMagn16 :: {-# UNPACK #-} !Double
        -- ^ peak log e-value of the magnitude component at @16c@.
      , Result -> [(Double, Double)]
resCdf        :: ![(Double, Double)]
        -- ^ the CDF channel: each warmup-fixed cut point (ascending)
        --   with its component's peak log e-value, so a CDF-driven
        --   rejection names the threshold that separated the classes.
        --   Empty when warmup readings were degenerate.
      , Result -> Word64
resSeed       :: {-# UNPACK #-} !Word64
        -- ^ the order-bit seed the run used; feed it back as
        --   'cfgSeed' to replay the same A\/B order.
      , Result -> Maybe Double
resMargin     :: !(Maybe Double)
        -- ^ the /absolute/ margin resolved from 'cfgMargin', in meter
        --   units per batch; 'Nothing' under the sharp null. When
        --   present, a 'Reject' means the mean effect exceeds it, and
        --   a high 'resPeakSign' on a 'Pass' marks a systematic within
        --   tolerance.
      }
  | Pass
      { resPairs      :: {-# UNPACK #-} !Int
      , resPeakLogW   :: {-# UNPACK #-} !Double
      , resPValue     :: {-# UNPACK #-} !Double
      , resEffect     :: !(Double, Double)
      , resClipped    :: {-# UNPACK #-} !Int
      , resClipped4   :: {-# UNPACK #-} !Int
      , resClipped16  :: {-# UNPACK #-} !Int
      , resBound      :: {-# UNPACK #-} !Double
      , resPeakSign   :: {-# UNPACK #-} !Double
      , resPeakMagn   :: {-# UNPACK #-} !Double
      , resPeakMagn4  :: {-# UNPACK #-} !Double
      , resPeakMagn16 :: {-# UNPACK #-} !Double
      , resCdf        :: ![(Double, Double)]
      , resSeed       :: {-# UNPACK #-} !Word64
      , resMargin     :: !(Maybe Double)
      }
  deriving Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
Show

-- | The largest peak log e-value across the CDF-indicator
--   components — @0@ when warmup resolved no cut points. A maximum
--   over 'resCdf', which keeps the per-cut-point detail.
resPeakCdf :: Result -> Double
resPeakCdf :: Result -> Double
resPeakCdf = ((Double, Double) -> Double -> Double)
-> Double -> [(Double, Double)] -> Double
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Double
_, Double
p) Double
acc -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
p Double
acc) Double
0 ([(Double, Double)] -> Double)
-> (Result -> [(Double, Double)]) -> Result -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> [(Double, Double)]
resCdf

-- | An actionable observation about a t'Result', produced by
--   'diagnose'.
data Advisory
  = HighClipRate !ClipRates
    -- ^ More than 5% of pairs were clipped at @c@, starving the tight
    --   magnitude component: raise 'cfgWarmup' or 'cfgBatch', or
    --   treat the run with suspicion. Carries the rate at all three
    --   bounds; a nonzero rate at @16c@ means 'resEffect' describes a
    --   truncated variable.
  | LowPower !Double
    -- ^ On 'Pass' only: the effect-interval half-width exceeded the
    --   tight clip bound @c@ (the ratio is carried here, in units of
    --   @c@). Leaks with a mean shift below that scale would not have
    --   been resolved by this run; raise 'cfgBudget' to sharpen the
    --   interval.
  | RejectionDriver !LeakShape
    -- ^ On 'Reject' only: which channel of the hedge drove the
    --   detection, i.e. what shape of leak was found.
  deriving (Advisory -> Advisory -> Bool
(Advisory -> Advisory -> Bool)
-> (Advisory -> Advisory -> Bool) -> Eq Advisory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Advisory -> Advisory -> Bool
== :: Advisory -> Advisory -> Bool
$c/= :: Advisory -> Advisory -> Bool
/= :: Advisory -> Advisory -> Bool
Eq, Int -> Advisory -> ShowS
[Advisory] -> ShowS
Advisory -> String
(Int -> Advisory -> ShowS)
-> (Advisory -> String) -> ([Advisory] -> ShowS) -> Show Advisory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Advisory -> ShowS
showsPrec :: Int -> Advisory -> ShowS
$cshow :: Advisory -> String
show :: Advisory -> String
$cshowList :: [Advisory] -> ShowS
showList :: [Advisory] -> ShowS
Show)

-- | The share of pairs clipped at each of the hedge's three
--   magnitude bounds, carried by 'HighClipRate'. Nested by
--   construction: @clipWidest <= clipWide <= clipTight@, since
--   @|d| > 16c@ implies @|d| > 4c@ implies @|d| > c@.
data ClipRates = ClipRates
  { ClipRates -> Double
clipTight  :: {-# UNPACK #-} !Double
    -- ^ fraction of pairs with @|d| > c@.
  , ClipRates -> Double
clipWide   :: {-# UNPACK #-} !Double
    -- ^ fraction of pairs with @|d| > 4c@.
  , ClipRates -> Double
clipWidest :: {-# UNPACK #-} !Double
    -- ^ fraction of pairs with @|d| > 16c@ — the bound behind
    --   'resEffect'.
  } deriving (ClipRates -> ClipRates -> Bool
(ClipRates -> ClipRates -> Bool)
-> (ClipRates -> ClipRates -> Bool) -> Eq ClipRates
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClipRates -> ClipRates -> Bool
== :: ClipRates -> ClipRates -> Bool
$c/= :: ClipRates -> ClipRates -> Bool
/= :: ClipRates -> ClipRates -> Bool
Eq, Int -> ClipRates -> ShowS
[ClipRates] -> ShowS
ClipRates -> String
(Int -> ClipRates -> ShowS)
-> (ClipRates -> String)
-> ([ClipRates] -> ShowS)
-> Show ClipRates
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClipRates -> ShowS
showsPrec :: Int -> ClipRates -> ShowS
$cshow :: ClipRates -> String
show :: ClipRates -> String
$cshowList :: [ClipRates] -> ShowS
showList :: [ClipRates] -> ShowS
Show)

-- | The qualitative shape of a leak, inferred from the per-component
--   peaks of the hedge. Reported by 'RejectionDriver' and available
--   standalone via 'leakShape'.
data LeakShape
  = BulkShift
    -- ^ 'resPeakMagn' (tight magnitude) dominates: a small consistent
    --   mean shift in @d@.
  | ShapeLeak
    -- ^ 'resPeakSign' dominates: an equal-mean asymmetry of the
    --   difference itself (@P(d > 0) \/= 1\/2@).
  | RareOutlier
    -- ^ 'resPeakMagn4' or 'resPeakMagn16' dominates: rare-tail
    --   outliers (e.g. a rarely-taken data-dependent branch).
  | CdfShift
    -- ^ 'resPeakCdf' dominates: the two classes' CDFs differ at a
    --   warmup-fixed cut point. Typical of a dispersion (variance)
    --   leak, which leaves @d@ symmetric and so registers on no
    --   other channel.
  | MixedShape
    -- ^ No single component peak dominates by @>= 1.5x@; the leak
    --   registers on several channels comparably.
  deriving (LeakShape -> LeakShape -> Bool
(LeakShape -> LeakShape -> Bool)
-> (LeakShape -> LeakShape -> Bool) -> Eq LeakShape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeakShape -> LeakShape -> Bool
== :: LeakShape -> LeakShape -> Bool
$c/= :: LeakShape -> LeakShape -> Bool
/= :: LeakShape -> LeakShape -> Bool
Eq, Int -> LeakShape -> ShowS
[LeakShape] -> ShowS
LeakShape -> String
(Int -> LeakShape -> ShowS)
-> (LeakShape -> String)
-> ([LeakShape] -> ShowS)
-> Show LeakShape
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeakShape -> ShowS
showsPrec :: Int -> LeakShape -> ShowS
$cshow :: LeakShape -> String
show :: LeakShape -> String
$cshowList :: [LeakShape] -> ShowS
showList :: [LeakShape] -> ShowS
Show)

-- | Interpret a t'Result': heavy clipping, a low-power 'Pass' (the
--   effect interval is wider than the tight bound), and, on
--   'Reject', which channel of the hedge drove the detection. Always
--   in that order, so tooling can match by position.
diagnose :: Result -> [Advisory]
diagnose :: Result -> [Advisory]
diagnose Result
r =
  let rate :: a -> Double
rate a
n = if Result -> Int
resPairs Result
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                 then Double
0
                 else a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Result -> Int
resPairs Result
r) :: Double)
      !rates :: ClipRates
rates = Double -> Double -> Double -> ClipRates
ClipRates (Int -> Double
forall {a}. Integral a => a -> Double
rate (Result -> Int
resClipped Result
r)) (Int -> Double
forall {a}. Integral a => a -> Double
rate (Result -> Int
resClipped4 Result
r))
                         (Int -> Double
forall {a}. Integral a => a -> Double
rate (Result -> Int
resClipped16 Result
r))
      -- the counts nest, so the tight rate is the largest of the
      -- three and one trigger covers the profile
      clipA :: [Advisory]
clipA = [ClipRates -> Advisory
HighClipRate ClipRates
rates | ClipRates -> Double
clipTight ClipRates
rates Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0.05]
      powerA :: [Advisory]
powerA = case Result
r of
        Pass{} ->
          let !hw :: Double
hw = ((Double, Double) -> Double
forall a b. (a, b) -> b
snd (Result -> (Double, Double)
resEffect Result
r) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double, Double) -> Double
forall a b. (a, b) -> a
fst (Result -> (Double, Double)
resEffect Result
r)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
              !c :: Double
c  = Result -> Double
resBound Result
r
          in  [Double -> Advisory
LowPower (Double
hw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
c) | Double
c Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
hw Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
c]
        Reject{} -> []
      drvA :: [Advisory]
drvA = case Result
r of
        Reject{} -> [LeakShape -> Advisory
RejectionDriver (Result -> LeakShape
leakShape Result
r)]
        Pass{}   -> []
  in  [Advisory]
clipA [Advisory] -> [Advisory] -> [Advisory]
forall a. [a] -> [a] -> [a]
++ [Advisory]
powerA [Advisory] -> [Advisory] -> [Advisory]
forall a. [a] -> [a] -> [a]
++ [Advisory]
drvA

-- | Identify which channel of the hedge has the largest peak log
--   e-value in a t'Result', binning the two wider magnitude
--   components together as 'RareOutlier' and the CDF-indicator
--   components together as 'CdfShift'. Returns 'MixedShape' when no
--   single peak exceeds the next-largest by a factor of @1.5@.
--
--   Only meaningful on a 'Reject' — on a 'Pass' every peak sits near
--   the calibrated floor of @0@ and the returned shape is not
--   informative.
--
--   Under a margin-mode run ('resMargin' present) only the gating
--   magnitude components are ranked: the sign and CDF peaks did not
--   drive the verdict there, and a sub-margin systematic routinely
--   inflates them.
leakShape :: Result -> LeakShape
leakShape :: Result -> LeakShape
leakShape Result
r =
  let !sig :: Double
sig  = Result -> Double
resPeakSign Result
r
      !mag :: Double
mag  = Result -> Double
resPeakMagn Result
r
      !tl :: Double
tl   = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Result -> Double
resPeakMagn4 Result
r) (Result -> Double
resPeakMagn16 Result
r)
      !cdf :: Double
cdf  = Result -> Double
resPeakCdf Result
r
      candidates :: [(Double, LeakShape)]
candidates = case Result -> Maybe Double
resMargin Result
r of
        Just Double
_  -> [ (Double
mag, LeakShape
BulkShift)
                   , (Double
tl,  LeakShape
RareOutlier)
                   ]
        Maybe Double
Nothing -> [ (Double
sig, LeakShape
ShapeLeak)
                   , (Double
mag, LeakShape
BulkShift)
                   , (Double
tl,  LeakShape
RareOutlier)
                   , (Double
cdf, LeakShape
CdfShift)
                   ]
      ranked :: [(Double, LeakShape)]
ranked = ((Double, LeakShape) -> (Double, LeakShape) -> Ordering)
-> [(Double, LeakShape)] -> [(Double, LeakShape)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Double, LeakShape)
a (Double, LeakShape)
b -> Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Double, LeakShape) -> Double
forall a b. (a, b) -> a
fst (Double, LeakShape)
b) ((Double, LeakShape) -> Double
forall a b. (a, b) -> a
fst (Double, LeakShape)
a)) [(Double, LeakShape)]
candidates
  in  case [(Double, LeakShape)]
ranked of
        (Double
p1, LeakShape
s1) : (Double
p2, LeakShape
_) : [(Double, LeakShape)]
_
          | Double
p1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 Double
p2 -> LeakShape
s1
          | Bool
otherwise           -> LeakShape
MixedShape
        [(Double, LeakShape)]
_ -> LeakShape
MixedShape

-- | Errors thrown by 'runCT' when calibration or configuration fails.
data CensorError =
    WarmupZeroDuration
    -- ^ warmup observed only zero-duration measurements: the meter
    --   cannot resolve the target under the current 'cfgBatch'.
    --   Raise the batch size so the target runs in an inner loop.
    --   (Zero /differences/ across all warmup pairs are OK — that
    --   just means the target is deterministic in @|d|@ for the
    --   sampled inputs, which is the expected happy path under a
    --   PMU meter on truly CT code.)
  | InvalidConfig !String
    -- ^ a t'Config' field was outside its admissible range. The
    --   'String' names which field and why.
  | InvalidEprocConfig !ConfigError
    -- ^ the underlying e-process rejected the test configuration
    --   derived from 'cfgAlpha' and the warmup-estimated bound. In
    --   practice this is reachable only via a 'cfgAlpha' outside
    --   @(0, 1)@; adjust 'cfgAlpha' to the standard significance
    --   range.
  deriving (CensorError -> CensorError -> Bool
(CensorError -> CensorError -> Bool)
-> (CensorError -> CensorError -> Bool) -> Eq CensorError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CensorError -> CensorError -> Bool
== :: CensorError -> CensorError -> Bool
$c/= :: CensorError -> CensorError -> Bool
/= :: CensorError -> CensorError -> Bool
Eq, Int -> CensorError -> ShowS
[CensorError] -> ShowS
CensorError -> String
(Int -> CensorError -> ShowS)
-> (CensorError -> String)
-> ([CensorError] -> ShowS)
-> Show CensorError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CensorError -> ShowS
showsPrec :: Int -> CensorError -> ShowS
$cshow :: CensorError -> String
show :: CensorError -> String
$cshowList :: [CensorError] -> ShowS
showList :: [CensorError] -> ShowS
Show)

instance Exception CensorError

-- | A per-pair snapshot of the driver's state, delivered to the
--   observer passed to 'runCTWith' after every main-phase pair. All
--   quantities are on the same scale as the corresponding 'Result'
--   fields; recording the stream of frames reconstructs the wealth
--   trajectory without reimplementing the driver.
data Frame = Frame
  { Frame -> Int
frPair    :: {-# UNPACK #-} !Int
    -- ^ pair index (1-based; excludes warmup).
  , Frame -> Double
frDiff    :: {-# UNPACK #-} !Double
    -- ^ the raw per-pair difference @d = ta - tb@, pre-clip.
  , Frame -> Double
frLogW    :: {-# UNPACK #-} !Double
    -- ^ the mixture's current log e-value at this pair.
  , Frame -> Double
frLogWSup :: {-# UNPACK #-} !Double
    -- ^ its supremum-so-far (the quantity the reject latches on).
  , Frame -> Double
frLo      :: {-# UNPACK #-} !Double
    -- ^ effect-interval lower endpoint (meter units per batch).
  , Frame -> Double
frHi      :: {-# UNPACK #-} !Double
    -- ^ effect-interval upper endpoint.
  , Frame -> Bool
frClipped :: !Bool
    -- ^ whether @|d|@ exceeded the warmup bound and was clipped.
  } deriving Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
(Int -> Frame -> ShowS)
-> (Frame -> String) -> ([Frame] -> ShowS) -> Show Frame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Frame -> ShowS
showsPrec :: Int -> Frame -> ShowS
$cshow :: Frame -> String
show :: Frame -> String
$cshowList :: [Frame] -> ShowS
showList :: [Frame] -> ShowS
Show

-- | Run a constant-time test, handing a t'Frame' to the observer after
--   every main-phase pair. The observer runs outside the timed
--   region and gets the frame lazily, so the no-op observer of
--   'runCT' costs nothing; a recording one reconstructs the
--   trajectory (see @record@ in "Censor.Runner").
--
--   1. /Warmup/: @cfgWarmup@ pairs fix the clip bound @c@ and the
--      CDF cut points (order statistics of the pooled readings, so
--      they carry no class information).
--   2. /Main/: each pair runs in random order, and every
--      component's functional of @(ta, tb)@ feeds its e-process. The
--      run halts when the mixture crosses @1 \/ alpha@ or the budget
--      runs out. @d@ clipped to @[-16c, 16c]@ also feeds the
--      confidence sequence behind 'resEffect'.
--
--   With 'cfgMargin' set, warmup also resolves the absolute margin,
--   and only the magnitude components gate the verdict.
--
--   Betting on @d@ rather than on the raw readings lets the bet size
--   scale with the noise, @p99(|d|)@, rather than with the target's
--   runtime: a large gain for slow targets with little jitter.
runCTWith
  :: Meter -> Config -> Hypothesis a -> (Frame -> IO ()) -> IO Result
runCTWith :: forall a.
Meter -> Config -> Hypothesis a -> (Frame -> IO ()) -> IO Result
runCTWith Meter
meter Config
cfg Hypothesis a
hyp Frame -> IO ()
observe = do
  Config -> IO ()
validateConfig Config
cfg
  (!root, !wSeed, !mSeed) <- Maybe Word64 -> IO (Word64, Word64, Word64)
resolveSeeds (Config -> Maybe Word64
cfgSeed Config
cfg)
  let !samplers = Hypothesis a -> SmallArray (IO a)
forall a. Hypothesis a -> SmallArray (IO a)
orderedSamplers Hypothesis a
hyp
      pair      = Meter
-> Config
-> Hypothesis a
-> SmallArray (IO a)
-> Word64
-> IO (Word64, Word64)
forall a.
Meter
-> Config
-> Hypothesis a
-> SmallArray (IO a)
-> Word64
-> IO (Word64, Word64)
runPair Meter
meter Config
cfg Hypothesis a
hyp SmallArray (IO a)
samplers
  ws  <- warmup cfg pair wSeed
  !ch <- channel cfg [ (fromIntegral x, fromIntegral y) | (x, y) <- ws ]
  let go !Int
n !ChanState
st !Word64
rng
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Config -> Int
cfgBudget Config
cfg = Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$! Chan -> Word64 -> Int -> ChanState -> Result
chanResult Chan
ch Word64
root Int
n ChanState
st
        | Bool
otherwise = do
            let (!Word64
rng', !Word64
bit) = Word64 -> (Word64, Word64)
nextOrderBit Word64
rng
            (!ta, !tb) <- Word64 -> IO (Word64, Word64)
pair Word64
bit
            let !xa  = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ta :: Double
                !xb  = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
tb :: Double
                !st' = Chan -> ChanState -> Double -> Double -> ChanState
stepChan Chan
ch ChanState
st Double
xa Double
xb
                !n'  = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
            -- lazy: the frame's fields (mixture reads) are forced
            -- only if the observer forces them, so runCT pays nothing.
            observe (chanFrame ch n' (xa - xb) st')
            if chanRejects ch st'
              then pure $! chanResult ch root n' st'
              else go n' st' rng'
  go 0 (chanInitial ch) mSeed

-- | Run a constant-time test. See 'runCTWith' for the phase-by-phase
--   description; this is that driver with the per-pair observer
--   discarded.
runCT :: Meter -> Config -> Hypothesis a -> IO Result
runCT :: forall a. Meter -> Config -> Hypothesis a -> IO Result
runCT Meter
meter Config
cfg Hypothesis a
hyp = Meter -> Config -> Hypothesis a -> (Frame -> IO ()) -> IO Result
forall a.
Meter -> Config -> Hypothesis a -> (Frame -> IO ()) -> IO Result
runCTWith Meter
meter Config
cfg Hypothesis a
hyp (\Frame
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Run a constant-time test and, if it rejects, qualify the
--   rejection with the A\/A and B\/B negative controls
--   ('attribute'). A 'Pass' returns 'Nothing' (no controls needed);
--   a 'Reject' returns @'Just' att@ reporting whether either
--   control convicted the harness. The controls re-run the test
--   twice, so this costs up to three runs on a rejection.
runCTAttributed
  :: Meter -> Config -> Hypothesis a -> IO (Result, Maybe Attribution)
runCTAttributed :: forall a.
Meter -> Config -> Hypothesis a -> IO (Result, Maybe Attribution)
runCTAttributed Meter
meter Config
cfg Hypothesis a
hyp = do
  r <- Meter -> Config -> Hypothesis a -> IO Result
forall a. Meter -> Config -> Hypothesis a -> IO Result
runCT Meter
meter Config
cfg Hypothesis a
hyp
  case r of
    Reject{} -> do
      att <- Meter -> Config -> Hypothesis a -> IO Attribution
forall a. Meter -> Config -> Hypothesis a -> IO Attribution
attribute Meter
meter Config
cfg Hypothesis a
hyp
      pure (r, Just att)
    Pass{}   -> (Result, Maybe Attribution) -> IO (Result, Maybe Attribution)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result
r, Maybe Attribution
forall a. Maybe a
Nothing)

-- | One value per channel of a split run ('runSplitWith'): a
--   t'Result' each, or the controls' t'Attribution' each.
data Split a = Split
  { forall a. Split a -> a
splitCycles :: !a
    -- ^ the cycle count: whether the code's execution depends on
    --   the class. The verdict is this channel's.
  , forall a. Split a -> a
splitPeriod :: !a
    -- ^ wall time per cycle, in femtoseconds: whether the clock the
    --   cycles ran at does.
  , forall a. Split a -> a
splitWall   :: !a
    -- ^ wall time, in nanoseconds: the two together, as elapsed
    --   time shows them to an observer.
  } deriving (Split a -> Split a -> Bool
(Split a -> Split a -> Bool)
-> (Split a -> Split a -> Bool) -> Eq (Split a)
forall a. Eq a => Split a -> Split a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Split a -> Split a -> Bool
== :: Split a -> Split a -> Bool
$c/= :: forall a. Eq a => Split a -> Split a -> Bool
/= :: Split a -> Split a -> Bool
Eq, Int -> Split a -> ShowS
[Split a] -> ShowS
Split a -> String
(Int -> Split a -> ShowS)
-> (Split a -> String) -> ([Split a] -> ShowS) -> Show (Split a)
forall a. Show a => Int -> Split a -> ShowS
forall a. Show a => [Split a] -> ShowS
forall a. Show a => Split a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Split a -> ShowS
showsPrec :: Int -> Split a -> ShowS
$cshow :: forall a. Show a => Split a -> String
show :: Split a -> String
$cshowList :: forall a. Show a => [Split a] -> ShowS
showList :: [Split a] -> ShowS
Show)

instance Functor Split where
  fmap :: forall a b. (a -> b) -> Split a -> Split b
fmap a -> b
f (Split a
c a
p a
w) = b -> b -> b -> Split b
forall a. a -> a -> a -> Split a
Split (a -> b
f a
c) (a -> b
f a
p) (a -> b
f a
w)

-- | Run a constant-time test under a t'SplitMeter', handing the
--   cycles channel's t'Frame' to the observer after every
--   main-phase pair.
--
--   Every pair is read once, as cycles and wall time, and tested on
--   three channels: cycles, the clock period (wall time per cycle),
--   and wall time. Each channel is a full test as 'runCTWith'
--   describes, with its own clip bound and cut points fixed by the
--   same warmup pairs, and each holds its own type-I error at
--   'cfgAlpha'. The cycles channel decides when the run stops: on
--   its rejection, or at the budget. That stop is a stopping time
--   for the readings of all three, and the order bit is independent
--   of all three, so the other two channels' guarantees hold where
--   it falls.
--
--   The cycles channel answers the constant-time question. The
--   period channel answers whether the clock moved with the class,
--   as it does when the core's frequency follows data-dependent
--   power; wall time answers whether elapsed time moved, by either
--   route. A wall rejection beside a cycles pass, with the period
--   rejecting too, is a frequency effect rather than a code path.
--
--   The period reads cleanly only beside a cycles pass: the counted
--   region carries a fixed overhead (the clock reads), so wall time
--   per cycle falls as cycles grow, and a cycles difference
--   registers on the period as well.
runSplitWith
  :: SplitMeter -> Config -> Hypothesis a -> (Frame -> IO ())
  -> IO (Split Result)
runSplitWith :: forall a.
SplitMeter
-> Config -> Hypothesis a -> (Frame -> IO ()) -> IO (Split Result)
runSplitWith SplitMeter
meter Config
cfg Hypothesis a
hyp Frame -> IO ()
observe = do
  Config -> IO ()
validateConfig Config
cfg
  (!root, !wSeed, !mSeed) <- Maybe Word64 -> IO (Word64, Word64, Word64)
resolveSeeds (Config -> Maybe Word64
cfgSeed Config
cfg)
  let !samplers = Hypothesis a -> SmallArray (IO a)
forall a. Hypothesis a -> SmallArray (IO a)
orderedSamplers Hypothesis a
hyp
      pair      = SplitMeter
-> Config
-> Hypothesis a
-> SmallArray (IO a)
-> Word64
-> IO (Word64, Word64, Word64, Word64)
forall a.
SplitMeter
-> Config
-> Hypothesis a
-> SmallArray (IO a)
-> Word64
-> IO (Word64, Word64, Word64, Word64)
runSplitPair SplitMeter
meter Config
cfg Hypothesis a
hyp SmallArray (IO a)
samplers
  ws <- warmup cfg pair wSeed
  let rs = ((Word64, Word64, Word64, Word64) -> Split (Double, Double))
-> [(Word64, Word64, Word64, Word64)] -> [Split (Double, Double)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64, Word64, Word64, Word64) -> Split (Double, Double)
splitReadings [(Word64, Word64, Word64, Word64)]
ws
  !cc <- channel cfg (fmap splitCycles rs)
  !cp <- channel cfg (fmap splitPeriod rs)
  !cw <- channel cfg (fmap splitWall rs)
  let finish !Int
n !ChanState
sc !ChanState
sp !ChanState
sw = Result -> Result -> Result -> Split Result
forall a. a -> a -> a -> Split a
Split
        (Chan -> Word64 -> Int -> ChanState -> Result
chanResult Chan
cc Word64
root Int
n ChanState
sc)
        (Chan -> Word64 -> Int -> ChanState -> Result
chanResult Chan
cp Word64
root Int
n ChanState
sp)
        (Chan -> Word64 -> Int -> ChanState -> Result
chanResult Chan
cw Word64
root Int
n ChanState
sw)
      go !Int
n !ChanState
sc !ChanState
sp !ChanState
sw !Word64
rng
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Config -> Int
cfgBudget Config
cfg = Split Result -> IO (Split Result)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Split Result -> IO (Split Result))
-> Split Result -> IO (Split Result)
forall a b. (a -> b) -> a -> b
$! Int -> ChanState -> ChanState -> ChanState -> Split Result
finish Int
n ChanState
sc ChanState
sp ChanState
sw
        | Bool
otherwise = do
            let (!Word64
rng', !Word64
bit) = Word64 -> (Word64, Word64)
nextOrderBit Word64
rng
            !r <- Word64 -> IO (Word64, Word64, Word64, Word64)
pair Word64
bit
            case splitReadings r of
              Split (!Double
ca, !Double
cb) (!Double
pa, !Double
pb) (!Double
wa, !Double
wb) -> do
                let !sc' :: ChanState
sc' = Chan -> ChanState -> Double -> Double -> ChanState
stepChan Chan
cc ChanState
sc Double
ca Double
cb
                    !sp' :: ChanState
sp' = Chan -> ChanState -> Double -> Double -> ChanState
stepChan Chan
cp ChanState
sp Double
pa Double
pb
                    !sw' :: ChanState
sw' = Chan -> ChanState -> Double -> Double -> ChanState
stepChan Chan
cw ChanState
sw Double
wa Double
wb
                    !n' :: Int
n'  = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                Frame -> IO ()
observe (Chan -> Int -> Double -> ChanState -> Frame
chanFrame Chan
cc Int
n' (Double
ca Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cb) ChanState
sc')
                if Chan -> ChanState -> Bool
chanRejects Chan
cc ChanState
sc'
                  then Split Result -> IO (Split Result)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Split Result -> IO (Split Result))
-> Split Result -> IO (Split Result)
forall a b. (a -> b) -> a -> b
$! Int -> ChanState -> ChanState -> ChanState -> Split Result
finish Int
n' ChanState
sc' ChanState
sp' ChanState
sw'
                  else Int
-> ChanState
-> ChanState
-> ChanState
-> Word64
-> IO (Split Result)
go Int
n' ChanState
sc' ChanState
sp' ChanState
sw' Word64
rng'
  go 0 (chanInitial cc) (chanInitial cp) (chanInitial cw) mSeed

-- | 'runSplitWith' with the per-pair observer discarded.
runSplit :: SplitMeter -> Config -> Hypothesis a -> IO (Split Result)
runSplit :: forall a. SplitMeter -> Config -> Hypothesis a -> IO (Split Result)
runSplit SplitMeter
meter Config
cfg Hypothesis a
hyp = SplitMeter
-> Config -> Hypothesis a -> (Frame -> IO ()) -> IO (Split Result)
forall a.
SplitMeter
-> Config -> Hypothesis a -> (Frame -> IO ()) -> IO (Split Result)
runSplitWith SplitMeter
meter Config
cfg Hypothesis a
hyp (\Frame
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | The A\/A and B\/B controls under a t'SplitMeter': each control
--   is one split run, and each channel's verdict comes from that
--   channel's readings of the two. Only meaningful for a channel
--   that rejected, as for 'attribute'.
attributeSplit
  :: SplitMeter -> Config -> Hypothesis a -> IO (Split Attribution)
attributeSplit :: forall a.
SplitMeter -> Config -> Hypothesis a -> IO (Split Attribution)
attributeSplit SplitMeter
meter Config
cfg Hypothesis a
hyp = do
  Split ac ap aw <- SplitMeter -> Config -> Hypothesis a -> IO (Split Result)
forall a. SplitMeter -> Config -> Hypothesis a -> IO (Split Result)
runSplit SplitMeter
meter Config
cfg (Hypothesis a -> Hypothesis a
forall a. Hypothesis a -> Hypothesis a
toAA Hypothesis a
hyp)
  Split bc bp bw <- runSplit meter cfg (toBB hyp)
  pure $! Split (attribution ac bc) (attribution ap bp)
                (attribution aw bw)

-- | Pick a 'cfgBatch' that lifts the per-batch reading well above the
--   meter's resolution: probe a class-A sample at geometrically
--   growing batches until the reading reaches a target magnitude,
--   then scale to it. Only meaningful for targets that recompute on
--   every repetition (see 'cfgBatch').
--
--   > b <- calibrateBatch meter hyp
--   > r <- runCT meter cfg { cfgBatch = b } hyp
--
--   Consumes one 'prepare' and one class-A draw; build a fresh
--   hypothesis for the run if its sampler stream must start
--   undisturbed. Returns @1@ if the meter never resolves the target
--   (the run then throws 'WarmupZeroDuration'). The result is
--   meter-specific; pin 'cfgBatch' to compare meters.
calibrateBatch :: Meter -> Hypothesis a -> IO Int
calibrateBatch :: forall a. Meter -> Hypothesis a -> IO Int
calibrateBatch Meter
meter Hypothesis a
hyp = (CalibReport -> Int) -> IO CalibReport -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CalibReport -> Int
crBatch (Meter -> Hypothesis a -> IO CalibReport
forall a. Meter -> Hypothesis a -> IO CalibReport
calibrateBatchReport Meter
meter Hypothesis a
hyp)

-- | The probe history behind 'calibrateBatchReport', for when the
--   chosen batch surprises.
data CalibReport = CalibReport
  { CalibReport -> Int
crBatch     :: {-# UNPACK #-} !Int
    -- ^ the batch size the calibrator selected.
  , CalibReport -> [(Int, Word64)]
crProbes    :: ![(Int, Word64)]
    -- ^ @(batch, median reading)@ pairs, oldest first.
  , CalibReport -> Bool
crCapHit    :: !Bool
    -- ^ 'True' when the meter never reached 'crTargetMag' before
    --   the internal cap. 'crBatch' will then be @1@ and a
    --   subsequent 'runCT' will throw 'WarmupZeroDuration'.
  , CalibReport -> Double
crTargetMag :: {-# UNPACK #-} !Double
    -- ^ the target per-batch reading magnitude used for refinement.
  , CalibReport -> Maybe Noise
crNoise     :: !(Maybe Noise)
    -- ^ the meter's noise floor at 'crBatch', sampled right after
    --   selection; 'Nothing' on a cap-hit.
  } deriving Int -> CalibReport -> ShowS
[CalibReport] -> ShowS
CalibReport -> String
(Int -> CalibReport -> ShowS)
-> (CalibReport -> String)
-> ([CalibReport] -> ShowS)
-> Show CalibReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CalibReport -> ShowS
showsPrec :: Int -> CalibReport -> ShowS
$cshow :: CalibReport -> String
show :: CalibReport -> String
$cshowList :: [CalibReport] -> ShowS
showList :: [CalibReport] -> ShowS
Show

-- | Dispersion of meter readings, in per-batch meter units (the scale
--   of 'resBound' and 'resEffect'). Deterministic meters read an IQR
--   of @0@.
data Noise = Noise
  { Noise -> Word64
nsMedian :: {-# UNPACK #-} !Word64
    -- ^ median reading at the selected batch.
  , Noise -> Word64
nsIqr    :: {-# UNPACK #-} !Word64
    -- ^ interquartile range of readings at the selected batch.
  } deriving (Noise -> Noise -> Bool
(Noise -> Noise -> Bool) -> (Noise -> Noise -> Bool) -> Eq Noise
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Noise -> Noise -> Bool
== :: Noise -> Noise -> Bool
$c/= :: Noise -> Noise -> Bool
/= :: Noise -> Noise -> Bool
Eq, Int -> Noise -> ShowS
[Noise] -> ShowS
Noise -> String
(Int -> Noise -> ShowS)
-> (Noise -> String) -> ([Noise] -> ShowS) -> Show Noise
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Noise -> ShowS
showsPrec :: Int -> Noise -> ShowS
$cshow :: Noise -> String
show :: Noise -> String
$cshowList :: [Noise] -> ShowS
showList :: [Noise] -> ShowS
Show)

-- | 'calibrateBatch' with its t'CalibReport'.
calibrateBatchReport :: Meter -> Hypothesis a -> IO CalibReport
calibrateBatchReport :: forall a. Meter -> Hypothesis a -> IO CalibReport
calibrateBatchReport Meter
meter Hypothesis a
hyp = do
  Hypothesis a -> IO ()
forall a. Hypothesis a -> IO ()
prepare Hypothesis a
hyp
  !x <- Hypothesis a -> IO a
forall a. Hypothesis a -> IO a
sampleA Hypothesis a
hyp
  let !act = Hypothesis a -> a -> IO ()
forall a. Hypothesis a -> a -> IO ()
target Hypothesis a
hyp a
x
      -- grow the batch until the reading itself reaches the target
      -- magnitude, then refine down from that measurement. Estimating
      -- from a small probe would inflate per-call cost with the
      -- meter's fixed per-measurement overhead (e.g. the clock reads);
      -- at the resolved batch that overhead is amortised.
      -- a cap-hit means the median per-call reading is well below
      -- one meter unit at the largest probed batch, which no
      -- functioning meter produces (the batch loop alone costs more);
      -- return 1 so the subsequent run fails fast in warmup rather
      -- than grinding through zero readings at a million calls per
      -- measurement.
      probe !Int
b ![(Int, Word64)]
ps
        | Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
calibCap =
            CalibReport -> IO CalibReport
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CalibReport -> IO CalibReport) -> CalibReport -> IO CalibReport
forall a b. (a -> b) -> a -> b
$! Int -> Bool -> Maybe Noise -> [(Int, Word64)] -> CalibReport
finish Int
1 Bool
True Maybe Noise
forall a. Maybe a
Nothing [(Int, Word64)]
ps
        | Bool
otherwise = do
            !r <- Meter -> IO () -> Int -> IO Word64
probeReading Meter
meter IO ()
act Int
b
            let !ps' = (Int
b, Word64
r) (Int, Word64) -> [(Int, Word64)] -> [(Int, Word64)]
forall a. a -> [a] -> [a]
: [(Int, Word64)]
ps
            if fromIntegral r < calibTarget
              then probe (b * 4) ps'
              else do
                let !b' = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling
                       (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
calibTarget Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
r)
                    !bf = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
calibCap Int
b')
                !ns <- noiseReading meter act bf
                pure $! finish bf False (Just ns) ps'
      finish !Int
bf !Bool
cap !Maybe Noise
ns ![(Int, Word64)]
ps = CalibReport
        { crBatch :: Int
crBatch     = Int
bf
        , crProbes :: [(Int, Word64)]
crProbes    = [(Int, Word64)] -> [(Int, Word64)]
forall a. [a] -> [a]
reverse [(Int, Word64)]
ps
        , crCapHit :: Bool
crCapHit    = Bool
cap
        , crTargetMag :: Double
crTargetMag = Double
calibTarget
        , crNoise :: Maybe Noise
crNoise     = Maybe Noise
ns
        }
  probe 1 []

-- median reading over a few measurements at batch @b@: robust to a
-- single 0 (fast target straddling the quantum) or a single spike
-- (a scheduler hiccup on the wall clock).
probeReading :: Meter -> IO () -> Int -> IO Word64
probeReading :: Meter -> IO () -> Int -> IO Word64
probeReading Meter
meter IO ()
act Int
b =
  ([Word64] -> Word64) -> IO [Word64] -> IO Word64
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Noise -> Word64
nsMedian (Noise -> Word64) -> ([Word64] -> Noise) -> [Word64] -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word64] -> Noise
dispersion) (Int -> IO Word64 -> IO [Word64]
samples Int
calibProbes (Meter -> Int -> IO () -> IO Word64
measure Meter
meter Int
b IO ()
act))

-- dispersion of repeated readings at the selected batch: median and
-- interquartile range (nearest-rank quantiles), in per-batch meter
-- units. This is the meter's noise floor at the scale the driver
-- will observe, recorded as a snapshot of measurement conditions.
noiseReading :: Meter -> IO () -> Int -> IO Noise
noiseReading :: Meter -> IO () -> Int -> IO Noise
noiseReading Meter
meter IO ()
act Int
b =
  ([Word64] -> Noise) -> IO [Word64] -> IO Noise
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word64] -> Noise
dispersion (Int -> IO Word64 -> IO [Word64]
samples Int
noiseSamples (Meter -> Int -> IO () -> IO Word64
measure Meter
meter Int
b IO ()
act))

-- run a reading action @n@ times, forcing each reading as it lands.
samples :: Int -> IO Word64 -> IO [Word64]
samples :: Int -> IO Word64 -> IO [Word64]
samples Int
n IO Word64
act = Int -> IO [Word64]
forall {t}. (Eq t, Num t) => t -> IO [Word64]
go Int
n
  where
    go :: t -> IO [Word64]
go t
0 = [Word64] -> IO [Word64]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    go t
i = do
      !r <- IO Word64
act
      fmap (r :) (go (i - 1))

-- median and nearest-rank interquartile range of a reading list.
dispersion :: [Word64] -> Noise
dispersion :: [Word64] -> Noise
dispersion [Word64]
rs =
  let !srt :: [Word64]
srt = [Word64] -> [Word64]
forall a. Ord a => [a] -> [a]
sort [Word64]
rs
      !n :: Int
n   = [Word64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
srt
      !med :: Word64
med = Int -> [Word64] -> Word64
forall a. Num a => Int -> [a] -> a
nth (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Word64]
srt
      !q1 :: Word64
q1  = Int -> [Word64] -> Word64
forall a. Num a => Int -> [a] -> a
nth (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4) [Word64]
srt
      !q3 :: Word64
q3  = Int -> [Word64] -> Word64
forall a. Num a => Int -> [a] -> a
nth (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4) [Word64]
srt
  in  Noise { nsMedian :: Word64
nsMedian = Word64
med, nsIqr :: Word64
nsIqr = Word64
q3 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
q1 }

-- | Baseline cost of the target: median and IQR of single
--   measurements on fresh class-A draws (each after a 'prepare'), at
--   'cfgBatch', in the units of 'resEffect'. Unlike 'crNoise', which
--   remeasures one applied action (no-ops after the first, for a pure
--   target), every measurement here is genuine work. Give it its own
--   hypothesis instance if the run's sampler stream must start
--   undisturbed.
baselineReading :: Meter -> Config -> Hypothesis a -> IO Noise
baselineReading :: forall a. Meter -> Config -> Hypothesis a -> IO Noise
baselineReading Meter
meter Config
cfg Hypothesis a
hyp =
  ([Word64] -> Noise) -> IO [Word64] -> IO Noise
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word64] -> Noise
dispersion (Int -> IO Word64 -> IO [Word64]
samples Int
baselineSamples IO Word64
fresh)
  where
    fresh :: IO Word64
fresh = do
      Hypothesis a -> IO ()
forall a. Hypothesis a -> IO ()
prepare Hypothesis a
hyp
      !x <- Hypothesis a -> IO a
forall a. Hypothesis a -> IO a
sampleA Hypothesis a
hyp
      measure meter (cfgBatch cfg) (target hyp x)

baselineSamples :: Int
baselineSamples :: Int
baselineSamples = Int
15

-- the @k@th element of a sorted list (nearest-rank order statistic);
-- @0@ past the end.
nth :: Num a => Int -> [a] -> a
nth :: forall a. Num a => Int -> [a] -> a
nth Int
k [a]
xs = case Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
k [a]
xs of
  (a
v : [a]
_) -> a
v
  []      -> a
0

noiseSamples :: Int
noiseSamples :: Int
noiseSamples = Int
15

-- Target per-batch reading magnitude (meter units) and probe budget.
-- 65536 matches the known-good hand-tuned batch for nanosecond-scale
-- targets (batch ~2000 at ~30 ns/call); erring high favours power,
-- since an underpowered default that misses a real leak is the
-- dangerous failure mode for a constant-time tester.
calibTarget :: Double
calibTarget :: Double
calibTarget = Double
65536

calibCap :: Int
calibCap :: Int
calibCap = Int
1000000

calibProbes :: Int
calibProbes :: Int
calibProbes = Int
5

-- | The /A\/A control/: 'sampleB' replaced by 'sampleA'. The
--   hypothesis is then H_0 by construction, so a 'Reject' indicts
--   the harness (unbalanced samplers, RTS state, order effects)
--   rather than the target. Pair with 'toBB'.
toAA :: Hypothesis a -> Hypothesis a
toAA :: forall a. Hypothesis a -> Hypothesis a
toAA Hypothesis a
h = Hypothesis a
h { sampleB = sampleA h }
{-# INLINE toAA #-}

-- | @'runCT' meter cfg ('toAA' hyp)@.
runAA :: Meter -> Config -> Hypothesis a -> IO Result
runAA :: forall a. Meter -> Config -> Hypothesis a -> IO Result
runAA Meter
meter Config
cfg Hypothesis a
hyp = Meter -> Config -> Hypothesis a -> IO Result
forall a. Meter -> Config -> Hypothesis a -> IO Result
runCT Meter
meter Config
cfg (Hypothesis a -> Hypothesis a
forall a. Hypothesis a -> Hypothesis a
toAA Hypothesis a
hyp)

-- | The /B\/B control/: 'sampleA' replaced by 'sampleB', catching
--   asymmetries specific to 'sampleB' that 'toAA' cannot see.
toBB :: Hypothesis a -> Hypothesis a
toBB :: forall a. Hypothesis a -> Hypothesis a
toBB Hypothesis a
h = Hypothesis a
h { sampleA = sampleB h }
{-# INLINE toBB #-}

-- | @'runCT' meter cfg ('toBB' hyp)@.
runBB :: Meter -> Config -> Hypothesis a -> IO Result
runBB :: forall a. Meter -> Config -> Hypothesis a -> IO Result
runBB Meter
meter Config
cfg Hypothesis a
hyp = Meter -> Config -> Hypothesis a -> IO Result
forall a. Meter -> Config -> Hypothesis a -> IO Result
runCT Meter
meter Config
cfg (Hypothesis a -> Hypothesis a
forall a. Hypothesis a -> Hypothesis a
toBB Hypothesis a
hyp)

-- | The outcome of the A\/A and B\/B controls. They can convict the
--   harness but not acquit it: each compares a sampler against
--   itself, so an asymmetry only /between/ the samplers (say, one
--   returns a thunk that the target forces while timed) is invisible
--   to both.
data ControlVerdict
  = ControlsPass
    -- ^ Neither control rejected. A primary 'Reject' is then
    --   consistent with a target leak, not proof of one.
  | SampleAAsymmetry
    -- ^ The A\/A control rejected: 'sampleA' itself induces a
    --   timing asymmetry, and the primary verdict is not
    --   informative until it is fixed.
  | SampleBAsymmetry
    -- ^ The B\/B control rejected: as above, for 'sampleB'.
  | PervasiveAsymmetry
    -- ^ Both controls rejected: the harness asymmetry is not
    --   specific to either sampler.
  deriving (ControlVerdict -> ControlVerdict -> Bool
(ControlVerdict -> ControlVerdict -> Bool)
-> (ControlVerdict -> ControlVerdict -> Bool) -> Eq ControlVerdict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ControlVerdict -> ControlVerdict -> Bool
== :: ControlVerdict -> ControlVerdict -> Bool
$c/= :: ControlVerdict -> ControlVerdict -> Bool
/= :: ControlVerdict -> ControlVerdict -> Bool
Eq, Int -> ControlVerdict -> ShowS
[ControlVerdict] -> ShowS
ControlVerdict -> String
(Int -> ControlVerdict -> ShowS)
-> (ControlVerdict -> String)
-> ([ControlVerdict] -> ShowS)
-> Show ControlVerdict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ControlVerdict -> ShowS
showsPrec :: Int -> ControlVerdict -> ShowS
$cshow :: ControlVerdict -> String
show :: ControlVerdict -> String
$cshowList :: [ControlVerdict] -> ShowS
showList :: [ControlVerdict] -> ShowS
Show)

-- | The control verdict with both control runs in full, so the
--   evidence can be inspected rather than taken on trust.
data Attribution = Attribution
  { Attribution -> ControlVerdict
attVerdict :: !ControlVerdict
    -- ^ the combined outcome.
  , Attribution -> Result
attAA      :: !Result
    -- ^ the complete A\/A control run.
  , Attribution -> Result
attBB      :: !Result
    -- ^ the complete B\/B control run.
  } deriving Int -> Attribution -> ShowS
[Attribution] -> ShowS
Attribution -> String
(Int -> Attribution -> ShowS)
-> (Attribution -> String)
-> ([Attribution] -> ShowS)
-> Show Attribution
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Attribution -> ShowS
showsPrec :: Int -> Attribution -> ShowS
$cshow :: Attribution -> String
show :: Attribution -> String
$cshowList :: [Attribution] -> ShowS
showList :: [Attribution] -> ShowS
Show

-- | Run the A\/A and B\/B controls. Only meaningful after a
--   'Reject': on a symmetric harness both pass whether or not the
--   target leaks.
attribute :: Meter -> Config -> Hypothesis a -> IO Attribution
attribute :: forall a. Meter -> Config -> Hypothesis a -> IO Attribution
attribute Meter
meter Config
cfg Hypothesis a
hyp = do
  raa <- Meter -> Config -> Hypothesis a -> IO Result
forall a. Meter -> Config -> Hypothesis a -> IO Result
runAA Meter
meter Config
cfg Hypothesis a
hyp
  rbb <- runBB meter cfg hyp
  pure $! attribution raa rbb

-- the controls' combined verdict, carrying both runs.
attribution :: Result -> Result -> Attribution
attribution :: Result -> Result -> Attribution
attribution Result
raa Result
rbb =
  let !v :: ControlVerdict
v = case (Result
raa, Result
rbb) of
        (Pass{},   Pass{})   -> ControlVerdict
ControlsPass
        (Reject{}, Pass{})   -> ControlVerdict
SampleAAsymmetry
        (Pass{},   Reject{}) -> ControlVerdict
SampleBAsymmetry
        (Reject{}, Reject{}) -> ControlVerdict
PervasiveAsymmetry
  in  Attribution
        { attVerdict :: ControlVerdict
attVerdict = ControlVerdict
v
        , attAA :: Result
attAA      = Result
raa
        , attBB :: Result
attBB      = Result
rbb
        }

-- internal

validateConfig :: Config -> IO ()
validateConfig :: Config -> IO ()
validateConfig Config{Double
Int
Maybe Double
Maybe Word64
cfgAlpha :: Config -> Double
cfgBudget :: Config -> Int
cfgBatch :: Config -> Int
cfgWarmup :: Config -> Int
cfgSeed :: Config -> Maybe Word64
cfgMargin :: Config -> Maybe Double
cfgAlpha :: Double
cfgBudget :: Int
cfgBatch :: Int
cfgWarmup :: Int
cfgSeed :: Maybe Word64
cfgMargin :: Maybe Double
..}
  | Int
cfgBatch  Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = CensorError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CensorError -> IO ()) -> CensorError -> IO ()
forall a b. (a -> b) -> a -> b
$! String -> CensorError
InvalidConfig
      String
"cfgBatch must be positive"
  | Int
cfgWarmup Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = CensorError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CensorError -> IO ()) -> CensorError -> IO ()
forall a b. (a -> b) -> a -> b
$! String -> CensorError
InvalidConfig
      String
"cfgWarmup must be positive"
  | Int
cfgBudget Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0 = CensorError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CensorError -> IO ()) -> CensorError -> IO ()
forall a b. (a -> b) -> a -> b
$! String -> CensorError
InvalidConfig
      String
"cfgBudget must be nonnegative"
  | Just Double
m <- Maybe Double
cfgMargin
  , Bool -> Bool
not (Double
m Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
m) Bool -> Bool -> Bool
&& Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
m)) =
      CensorError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CensorError -> IO ()) -> CensorError -> IO ()
forall a b. (a -> b) -> a -> b
$! String -> CensorError
InvalidConfig
        String
"cfgMargin must be a positive finite fraction"
  | Bool
otherwise      = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | The two samplers, indexed by the per-pair order word: slot 0
--   holds 'sampleA', slot 1 'sampleB'. Built once per run so the
--   driver's pair loop selects a sampler by indexing — a
--   data-dependent load — rather than by branching on the order
--   bit. Both elements live in one cache line, so the selection's
--   microarchitectural footprint is as small as it can be made.
orderedSamplers :: Hypothesis a -> SmallArray (IO a)
orderedSamplers :: forall a. Hypothesis a -> SmallArray (IO a)
orderedSamplers Hypothesis a
hyp =
  let !sa :: IO a
sa = Hypothesis a -> IO a
forall a. Hypothesis a -> IO a
sampleA Hypothesis a
hyp
      !sb :: IO a
sb = Hypothesis a -> IO a
forall a. Hypothesis a -> IO a
sampleB Hypothesis a
hyp
  in  Int -> [IO a] -> SmallArray (IO a)
forall a. Int -> [a] -> SmallArray a
smallArrayFromListN Int
2 [IO a
sa, IO a
sb]

-- | Run one (sample, measure, sample, measure) pair in the order
--   given by the order word (@0@ = A first, @1@ = B first) and return
--   (A's reading, B's reading). 'prepare' runs first, outside the
--   timed region.
--
--   The order bit is data only: one code path, the sampler chosen by
--   array index, the labels recovered by mask arithmetic. A branch
--   on the bit would give the two orders distinct code paths and
--   couple the bit into the readings through microarchitectural
--   state, breaking exchangeability (see @issues/handled/ISSUE2.md@).
runPair
  :: Meter -> Config -> Hypothesis a -> SmallArray (IO a) -> Word64
  -> IO (Word64, Word64)
runPair :: forall a.
Meter
-> Config
-> Hypothesis a
-> SmallArray (IO a)
-> Word64
-> IO (Word64, Word64)
runPair Meter
meter Config
cfg Hypothesis a
hyp SmallArray (IO a)
samplers !Word64
bit = do
  Hypothesis a -> IO ()
forall a. Hypothesis a -> IO ()
prepare Hypothesis a
hyp
  let !iFst :: Int
iFst = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bit :: Int
      !iSnd :: Int
iSnd = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
iFst
  !u  <- SmallArray (IO a) -> Int -> IO a
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (IO a)
samplers Int
iFst
  !t1 <- measure meter (cfgBatch cfg) (target hyp u)
  !v  <- indexSmallArray samplers iSnd
  !t2 <- measure meter (cfgBatch cfg) (target hyp v)
  let (!x, !y) = unscramble bit t1 t2
  pure (x, y)
{-# INLINE runPair #-}

-- | 'runPair' under a t'SplitMeter': (A's cycles, A's wall time,
--   B's cycles, B's wall time), each reading unscrambled as there.
runSplitPair
  :: SplitMeter -> Config -> Hypothesis a -> SmallArray (IO a) -> Word64
  -> IO (Word64, Word64, Word64, Word64)
runSplitPair :: forall a.
SplitMeter
-> Config
-> Hypothesis a
-> SmallArray (IO a)
-> Word64
-> IO (Word64, Word64, Word64, Word64)
runSplitPair SplitMeter
meter Config
cfg Hypothesis a
hyp SmallArray (IO a)
samplers !Word64
bit = do
  Hypothesis a -> IO ()
forall a. Hypothesis a -> IO ()
prepare Hypothesis a
hyp
  let !iFst :: Int
iFst = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bit :: Int
      !iSnd :: Int
iSnd = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
iFst
  !u <- SmallArray (IO a) -> Int -> IO a
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (IO a)
samplers Int
iFst
  (!c1, !w1) <- measureSplit meter (cfgBatch cfg) (target hyp u)
  !v <- indexSmallArray samplers iSnd
  (!c2, !w2) <- measureSplit meter (cfgBatch cfg) (target hyp v)
  let (!ca, !cb) = unscramble bit c1 c2
      (!wa, !wb) = unscramble bit w1 w2
  pure (ca, wa, cb, wb)
{-# INLINE runSplitPair #-}

-- branchless unscramble: swap iff bit = 1, via an all-ones mask. The
-- first result is class A's reading (slot 1 when the bit is 0, slot
-- 2 when it is 1), the second class B's.
unscramble :: Word64 -> Word64 -> Word64 -> (Word64, Word64)
unscramble :: Word64 -> Word64 -> Word64 -> (Word64, Word64)
unscramble !Word64
bit !Word64
t1 !Word64
t2 =
  let !m :: Word64
m = Word64 -> Word64
forall a. Num a => a -> a
negate Word64
bit
      !s :: Word64
s = (Word64
t1 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`B.xor` Word64
t2) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
B..&. Word64
m
  in  (Word64
t1 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`B.xor` Word64
s, Word64
t2 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`B.xor` Word64
s)
{-# INLINE unscramble #-}

-- Each channel's (A, B) readings from a split pair. The period is
-- wall time per cycle in femtoseconds, fine enough that the clip
-- bound's floor of 1 sits far below its noise. A batch always
-- retires cycles; the floor on the divisor only keeps the ratio
-- total.
splitReadings :: (Word64, Word64, Word64, Word64) -> Split (Double, Double)
splitReadings :: (Word64, Word64, Word64, Word64) -> Split (Double, Double)
splitReadings (!Word64
ca, !Word64
wa, !Word64
cb, !Word64
wb) = (Double, Double)
-> (Double, Double) -> (Double, Double) -> Split (Double, Double)
forall a. a -> a -> a -> Split a
Split
  (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ca, Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cb)
  (Word64 -> Word64 -> Double
forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
period Word64
wa Word64
ca, Word64 -> Word64 -> Double
forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
period Word64
wb Word64
cb)
  (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
wa, Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
wb)
  where
    period :: a -> a -> a
period !a
w !a
c = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w a -> a -> a
forall a. Num a => a -> a -> a
* a
1.0e6 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> a -> a
forall a. Ord a => a -> a -> a
max a
1 a
c)

-- The hedge composition ----------------------------------------------------

-- The components are heterogeneous, so the driver steps each one
-- itself and hands their log e-values to 'EPMix.update' once per
-- pair. On a tie the sign component is unchanged, which is still its
-- current value, so the mixture's lockstep precondition holds. The
-- mixture owns the rejection latch and the threshold
-- @log(K \/ alpha)@, with @K = 4 + n@ for @n@ cut points: the
-- hedging price is @log K@ nats against @log(1 \/ alpha) = 13.8@ at
-- the default alpha. Under a margin only the three magnitude
-- components are mixed (@K = 3@); the sign and CDF ones are stepped
-- for their diagnostic peaks.

data HedgeCfg = HedgeCfg
  { HedgeCfg -> Config
hcSign   :: !EPSign.Config
  , HedgeCfg -> Config
hcMagn1  :: !EPMagn.Config
  , HedgeCfg -> Config
hcMagn2  :: !EPMagn.Config
  , HedgeCfg -> Config
hcMagn3  :: !EPMagn.Config
  , HedgeCfg -> Config
hcCdf    :: !EPMagn.Config          -- shared by every cut point
  , HedgeCfg -> [Double]
hcQs     :: ![Double]               -- the cut points themselves
  , HedgeCfg -> Config
hcMix    :: !EPMix.Config
  , HedgeCfg -> Double
hcC1     :: {-# UNPACK #-} !Double  -- tight clip level (base c)
  , HedgeCfg -> Double
hcC2     :: {-# UNPACK #-} !Double  -- 4c
  , HedgeCfg -> Double
hcC3     :: {-# UNPACK #-} !Double  -- 16c
  , HedgeCfg -> Maybe Double
hcMargin :: !(Maybe Double)         -- absolute margin; Nothing =
                                        -- sharp null
  }

data HedgeState = HedgeState
  { HedgeState -> State
hsSign  :: !EPSign.State
  , HedgeState -> State
hsMagn1 :: !EPMagn.State
  , HedgeState -> State
hsMagn2 :: !EPMagn.State
  , HedgeState -> State
hsMagn3 :: !EPMagn.State
  , HedgeState -> [State]
hsCdf   :: ![EPMagn.State]         -- aligned with 'hcQs'
  , HedgeState -> State
hsMix   :: !EPMix.State
  }

mkHedgeCfg
  :: Double -> Double -> [Double] -> Maybe Double
  -> Either ConfigError HedgeCfg
mkHedgeCfg :: Double
-> Double
-> [Double]
-> Maybe Double
-> Either ConfigError HedgeCfg
mkHedgeCfg !Double
alpha !Double
c [Double]
qs Maybe Double
mmargin = do
  let !c2 :: Double
c2 = Double
4  Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c
      !c3 :: Double
c3 = Double
16 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
c
      -- a magnitude component on d clipped to [-b, b]: mean-zero
      -- under the sharp null, anchored at ±delta under a margin.
      magn :: Double -> Either ConfigError Config
magn !Double
b = case Maybe Double
mmargin of
        Maybe Double
Nothing -> Double
-> Double
-> Double
-> Double
-> Bettor
-> Either ConfigError Config
EPMagn.config Double
0 (Double -> Double
forall a. Num a => a -> a
negate Double
b) Double
b Double
alpha Bettor
Newton
        Just Double
d  ->
          Double
-> Double
-> Double
-> Double
-> Double
-> Bettor
-> Either ConfigError Config
EPMagn.configInterval (Double -> Double
forall a. Num a => a -> a
negate Double
d) Double
d (Double -> Double
forall a. Num a => a -> a
negate Double
b) Double
b Double
alpha Bettor
Newton
      !k :: Int
k = case Maybe Double
mmargin of
        Maybe Double
Nothing -> Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
qs
        Just Double
_  -> Int
3
  !sc <- Double -> Double -> Bettor -> Either ConfigError Config
EPSign.config Double
0.5 Double
alpha Bettor
Newton
  !m1 <- magn c
  !m2 <- magn c2
  !m3 <- magn c3
  !cd <- EPMagn.config 0 (negate 1)  1  alpha Newton
  !mx <- EPMix.config k alpha
  pure HedgeCfg
    { hcSign   = sc
    , hcMagn1  = m1
    , hcMagn2  = m2
    , hcMagn3  = m3
    , hcCdf    = cd
    , hcQs     = qs
    , hcMix    = mx
    , hcC1     = c
    , hcC2     = c2
    , hcC3     = c3
    , hcMargin = mmargin
    }

-- One reading stream under test: its hedge and the confidence
-- sequence behind 'resEffect', both resting on the calibration
-- 'channel' fixes from the warmup pairs. A run tests one channel per
-- quantity it reads.
data Chan = Chan
  { Chan -> HedgeCfg
chHedge :: !HedgeCfg
  , Chan -> Config
chSeq   :: !EPCS.Config
  }

data ChanState = ChanState
  { ChanState -> HedgeState
csHedge :: !HedgeState
  , ChanState -> State
csSeq   :: !EPCS.State
  , ChanState -> (Double, Double)
csIv    :: !(Double, Double)  -- the latched effect interval
  , ChanState -> Clips
csClips :: !Clips
  }

-- Calibrate a channel from its warmup (A, B) readings, resolving the
-- margin against them. Throws as 'runCTWith' documents.
channel :: Config -> [(Double, Double)] -> IO Chan
channel :: Config -> [(Double, Double)] -> IO Chan
channel Config
cfg [(Double, Double)]
ws = do
  let (!Double
c, ![Double]
qs, !Bool
meterResolves, !Double
medR) = [(Double, Double)] -> (Double, [Double], Bool, Double)
calibrate [(Double, Double)]
ws
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
meterResolves (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CensorError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO CensorError
WarmupZeroDuration
  !mdelta <- case Config -> Maybe Double
cfgMargin Config
cfg of
    Maybe Double
Nothing  -> Maybe Double -> IO (Maybe Double)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Double
forall a. Maybe a
Nothing
    Just Double
rel -> do
      let !delta :: Double
delta = Double
rel Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
medR
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Double
delta Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CensorError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CensorError -> IO ()) -> CensorError -> IO ()
forall a b. (a -> b) -> a -> b
$! String -> CensorError
InvalidConfig
        String
"cfgMargin resolves to a zero absolute margin (warmup \
        \median reading is 0); raise cfgBatch"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Double
delta Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CensorError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CensorError -> IO ()) -> CensorError -> IO ()
forall a b. (a -> b) -> a -> b
$! String -> CensorError
InvalidConfig
        String
"cfgMargin resolves to an absolute margin at or above the \
        \warmup clip bound; lower cfgMargin (the tolerance exceeds \
        \the pair-noise scale the test bets against)"
      Maybe Double -> IO (Maybe Double)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
delta)
  !hcfg <- case mkHedgeCfg (cfgAlpha cfg) c qs mdelta of
    Left  ConfigError
e -> CensorError -> IO HedgeCfg
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ConfigError -> CensorError
InvalidEprocConfig ConfigError
e)
    Right HedgeCfg
x -> HedgeCfg -> IO HedgeCfg
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HedgeCfg
x
  !cscfg <- case EPCS.config (negate (hcC3 hcfg)) (hcC3 hcfg)
                   (cfgAlpha cfg) effectGrid of
    Left  ConfigError
e -> CensorError -> IO Config
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ConfigError -> CensorError
InvalidEprocConfig ConfigError
e)
    Right Config
x -> Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
x
  pure (Chan hcfg cscfg)

chanInitial :: Chan -> ChanState
chanInitial :: Chan -> ChanState
chanInitial Chan{Config
HedgeCfg
chHedge :: Chan -> HedgeCfg
chSeq :: Chan -> Config
chHedge :: HedgeCfg
chSeq :: Config
..} = ChanState
  { csHedge :: HedgeState
csHedge = HedgeCfg -> HedgeState
initialHedge HedgeCfg
chHedge
  , csSeq :: State
csSeq   = Config -> State
EPCS.initial Config
chSeq
  , csIv :: (Double, Double)
csIv    = (Double -> Double
forall a. Num a => a -> a
negate (HedgeCfg -> Double
hcC3 HedgeCfg
chHedge), HedgeCfg -> Double
hcC3 HedgeCfg
chHedge)
  , csClips :: Clips
csClips = Clips
noClips
  }

-- Step a channel on one pair's (A, B) readings. The effect interval
-- is latched: once the evidence pins the mean below the grid's
-- resolution the survivor set empties, and the last resolvable
-- interval (nested within all earlier ones, so still covered by the
-- time-uniform guarantee) is what 'chanResult' reports.
stepChan :: Chan -> ChanState -> Double -> Double -> ChanState
stepChan :: Chan -> ChanState -> Double -> Double -> ChanState
stepChan Chan{Config
HedgeCfg
chHedge :: Chan -> HedgeCfg
chSeq :: Chan -> Config
chHedge :: HedgeCfg
chSeq :: Config
..} ChanState{(Double, Double)
State
Clips
HedgeState
csHedge :: ChanState -> HedgeState
csSeq :: ChanState -> State
csIv :: ChanState -> (Double, Double)
csClips :: ChanState -> Clips
csHedge :: HedgeState
csSeq :: State
csIv :: (Double, Double)
csClips :: Clips
..} !Double
xa !Double
xb =
  let !d :: Double
d   = Double
xa Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
xb
      !h' :: HedgeState
h'  = HedgeCfg -> HedgeState -> Double -> Double -> Double -> HedgeState
updateHedge HedgeCfg
chHedge HedgeState
csHedge Double
d Double
xa Double
xb
      !s' :: State
s'  = Config -> State -> Double -> State
EPCS.update Config
chSeq State
csSeq (Double -> Double -> Double
clipD (HedgeCfg -> Double
hcC3 HedgeCfg
chHedge) Double
d)
      !iv' :: (Double, Double)
iv' = case Config -> State -> Maybe (Double, Double)
EPCS.interval Config
chSeq State
s' of
               Just (Double, Double)
x  -> (Double, Double)
x
               Maybe (Double, Double)
Nothing -> (Double, Double)
csIv
      !cl' :: Clips
cl' = HedgeCfg -> Clips -> Double -> Clips
bumpClips HedgeCfg
chHedge Clips
csClips Double
d
  in  HedgeState -> State -> (Double, Double) -> Clips -> ChanState
ChanState HedgeState
h' State
s' (Double, Double)
iv' Clips
cl'

-- Whether the channel's mixture has crossed its threshold; latched.
chanRejects :: Chan -> ChanState -> Bool
chanRejects :: Chan -> ChanState -> Bool
chanRejects Chan{Config
HedgeCfg
chHedge :: Chan -> HedgeCfg
chSeq :: Chan -> Config
chHedge :: HedgeCfg
chSeq :: Config
..} ChanState{(Double, Double)
State
Clips
HedgeState
csHedge :: ChanState -> HedgeState
csSeq :: ChanState -> State
csIv :: ChanState -> (Double, Double)
csClips :: ChanState -> Clips
csHedge :: HedgeState
csSeq :: State
csIv :: (Double, Double)
csClips :: Clips
..} =
  case Config -> State -> Verdict
EPMix.decide (HedgeCfg -> Config
hcMix HedgeCfg
chHedge) (HedgeState -> State
hsMix HedgeState
csHedge) of
    Verdict
EPMix.Reject -> Bool
True
    Verdict
_            -> Bool
False

-- The channel's frame after pair @n@, whose difference was @d@.
chanFrame :: Chan -> Int -> Double -> ChanState -> Frame
chanFrame :: Chan -> Int -> Double -> ChanState -> Frame
chanFrame Chan{Config
HedgeCfg
chHedge :: Chan -> HedgeCfg
chSeq :: Chan -> Config
chHedge :: HedgeCfg
chSeq :: Config
..} !Int
n !Double
d ChanState{(Double, Double)
State
Clips
HedgeState
csHedge :: ChanState -> HedgeState
csSeq :: ChanState -> State
csIv :: ChanState -> (Double, Double)
csClips :: ChanState -> Clips
csHedge :: HedgeState
csSeq :: State
csIv :: (Double, Double)
csClips :: Clips
..} = Int
-> Double -> Double -> Double -> Double -> Double -> Bool -> Frame
Frame Int
n Double
d
  (Config -> State -> Double
EPMix.log_evalue Config
mixc (HedgeState -> State
hsMix HedgeState
csHedge))
  (Config -> State -> Double
EPMix.log_evalue_sup Config
mixc (HedgeState -> State
hsMix HedgeState
csHedge))
  ((Double, Double) -> Double
forall a b. (a, b) -> a
fst (Double, Double)
csIv) ((Double, Double) -> Double
forall a b. (a, b) -> b
snd (Double, Double)
csIv)
  (Double -> Double
forall a. Num a => a -> a
abs Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> HedgeCfg -> Double
hcC1 HedgeCfg
chHedge)
  where
    mixc :: Config
mixc = HedgeCfg -> Config
hcMix HedgeCfg
chHedge

-- The channel's t'Result' after @n@ pairs, under the run's root seed.
chanResult :: Chan -> Word64 -> Int -> ChanState -> Result
chanResult :: Chan -> Word64 -> Int -> ChanState -> Result
chanResult ch :: Chan
ch@Chan{Config
HedgeCfg
chHedge :: Chan -> HedgeCfg
chSeq :: Chan -> Config
chHedge :: HedgeCfg
chSeq :: Config
..} !Word64
root !Int
n st :: ChanState
st@ChanState{(Double, Double)
State
Clips
HedgeState
csHedge :: ChanState -> HedgeState
csSeq :: ChanState -> State
csIv :: ChanState -> (Double, Double)
csClips :: ChanState -> Clips
csHedge :: HedgeState
csSeq :: State
csIv :: (Double, Double)
csClips :: Clips
..} = Int
-> Double
-> Double
-> (Double, Double)
-> Int
-> Int
-> Int
-> Double
-> Double
-> Double
-> Double
-> Double
-> [(Double, Double)]
-> Word64
-> Maybe Double
-> Result
ctor
  Int
n (Config -> State -> Double
EPMix.log_evalue_sup Config
mixc (HedgeState -> State
hsMix HedgeState
csHedge))
  (Config -> State -> Double
EPMix.p_value Config
mixc (HedgeState -> State
hsMix HedgeState
csHedge))
  (Double, Double)
csIv
  (Clips -> Int
clAtC Clips
csClips) (Clips -> Int
clAt4C Clips
csClips) (Clips -> Int
clAt16C Clips
csClips) (HedgeCfg -> Double
hcC1 HedgeCfg
chHedge)
  (State -> Double
EPSign.log_evalue_sup (HedgeState -> State
hsSign HedgeState
csHedge))
  (State -> Double
EPMagn.log_evalue_sup (HedgeState -> State
hsMagn1 HedgeState
csHedge))
  (State -> Double
EPMagn.log_evalue_sup (HedgeState -> State
hsMagn2 HedgeState
csHedge))
  (State -> Double
EPMagn.log_evalue_sup (HedgeState -> State
hsMagn3 HedgeState
csHedge))
  ([Double] -> [State] -> [(Double, Double)]
cdfPeaks (HedgeCfg -> [Double]
hcQs HedgeCfg
chHedge) (HedgeState -> [State]
hsCdf HedgeState
csHedge))
  Word64
root
  (HedgeCfg -> Maybe Double
hcMargin HedgeCfg
chHedge)
  where
    mixc :: Config
mixc = HedgeCfg -> Config
hcMix HedgeCfg
chHedge
    ctor :: Int
-> Double
-> Double
-> (Double, Double)
-> Int
-> Int
-> Int
-> Double
-> Double
-> Double
-> Double
-> Double
-> [(Double, Double)]
-> Word64
-> Maybe Double
-> Result
ctor | Chan -> ChanState -> Bool
chanRejects Chan
ch ChanState
st = Int
-> Double
-> Double
-> (Double, Double)
-> Int
-> Int
-> Int
-> Double
-> Double
-> Double
-> Double
-> Double
-> [(Double, Double)]
-> Word64
-> Maybe Double
-> Result
Reject
         | Bool
otherwise         = Int
-> Double
-> Double
-> (Double, Double)
-> Int
-> Int
-> Int
-> Double
-> Double
-> Double
-> Double
-> Double
-> [(Double, Double)]
-> Word64
-> Maybe Double
-> Result
Pass

-- Running clipped-pair tallies at the hedge's three magnitude
-- bounds. Kept as one strict record rather than three accumulator
-- arguments so the driver loop's arity does not grow with them.
data Clips = Clips
  { Clips -> Int
clAtC   :: {-# UNPACK #-} !Int
  , Clips -> Int
clAt4C  :: {-# UNPACK #-} !Int
  , Clips -> Int
clAt16C :: {-# UNPACK #-} !Int
  }

noClips :: Clips
noClips :: Clips
noClips = Int -> Int -> Int -> Clips
Clips Int
0 Int
0 Int
0

-- Tally one pair's difference against each bound. Sits outside the
-- timed region, alongside the e-process updates.
bumpClips :: HedgeCfg -> Clips -> Double -> Clips
bumpClips :: HedgeCfg -> Clips -> Double -> Clips
bumpClips HedgeCfg{Double
[Double]
Maybe Double
Config
Config
Config
hcSign :: HedgeCfg -> Config
hcMagn1 :: HedgeCfg -> Config
hcMagn2 :: HedgeCfg -> Config
hcMagn3 :: HedgeCfg -> Config
hcCdf :: HedgeCfg -> Config
hcQs :: HedgeCfg -> [Double]
hcMix :: HedgeCfg -> Config
hcC1 :: HedgeCfg -> Double
hcC2 :: HedgeCfg -> Double
hcC3 :: HedgeCfg -> Double
hcMargin :: HedgeCfg -> Maybe Double
hcSign :: Config
hcMagn1 :: Config
hcMagn2 :: Config
hcMagn3 :: Config
hcCdf :: Config
hcQs :: [Double]
hcMix :: Config
hcC1 :: Double
hcC2 :: Double
hcC3 :: Double
hcMargin :: Maybe Double
..} (Clips !Int
a !Int
b !Int
c) !Double
d = Int -> Int -> Int -> Clips
Clips
  (Double -> Int -> Int
forall {a}. Num a => Double -> a -> a
bump Double
hcC1 Int
a) (Double -> Int -> Int
forall {a}. Num a => Double -> a -> a
bump Double
hcC2 Int
b) (Double -> Int -> Int
forall {a}. Num a => Double -> a -> a
bump Double
hcC3 Int
c)
  where
    !m :: Double
m = Double -> Double
forall a. Num a => a -> a
abs Double
d
    bump :: Double -> a -> a
bump !Double
lim !a
n = if Double
m Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
lim then a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 else a
n
{-# INLINE bumpClips #-}

initialHedge :: HedgeCfg -> HedgeState
initialHedge :: HedgeCfg -> HedgeState
initialHedge HedgeCfg{Double
[Double]
Maybe Double
Config
Config
Config
hcSign :: HedgeCfg -> Config
hcMagn1 :: HedgeCfg -> Config
hcMagn2 :: HedgeCfg -> Config
hcMagn3 :: HedgeCfg -> Config
hcCdf :: HedgeCfg -> Config
hcQs :: HedgeCfg -> [Double]
hcMix :: HedgeCfg -> Config
hcC1 :: HedgeCfg -> Double
hcC2 :: HedgeCfg -> Double
hcC3 :: HedgeCfg -> Double
hcMargin :: HedgeCfg -> Maybe Double
hcSign :: Config
hcMagn1 :: Config
hcMagn2 :: Config
hcMagn3 :: Config
hcCdf :: Config
hcQs :: [Double]
hcMix :: Config
hcC1 :: Double
hcC2 :: Double
hcC3 :: Double
hcMargin :: Maybe Double
..} = HedgeState
  { hsSign :: State
hsSign  = Config -> State
EPSign.initial Config
hcSign
  , hsMagn1 :: State
hsMagn1 = Config -> State
EPMagn.initial Config
hcMagn1
  , hsMagn2 :: State
hsMagn2 = Config -> State
EPMagn.initial Config
hcMagn2
  , hsMagn3 :: State
hsMagn3 = Config -> State
EPMagn.initial Config
hcMagn3
  , hsCdf :: [State]
hsCdf   = (Double -> State) -> [Double] -> [State]
forall a b. (a -> b) -> [a] -> [b]
map (State -> Double -> State
forall a b. a -> b -> a
const (Config -> State
EPMagn.initial Config
hcCdf)) [Double]
hcQs
  , hsMix :: State
hsMix   = Config -> State
EPMix.initial Config
hcMix
  }

updateHedge
  :: HedgeCfg -> HedgeState -> Double -> Double -> Double -> HedgeState
updateHedge :: HedgeCfg -> HedgeState -> Double -> Double -> Double -> HedgeState
updateHedge HedgeCfg{Double
[Double]
Maybe Double
Config
Config
Config
hcSign :: HedgeCfg -> Config
hcMagn1 :: HedgeCfg -> Config
hcMagn2 :: HedgeCfg -> Config
hcMagn3 :: HedgeCfg -> Config
hcCdf :: HedgeCfg -> Config
hcQs :: HedgeCfg -> [Double]
hcMix :: HedgeCfg -> Config
hcC1 :: HedgeCfg -> Double
hcC2 :: HedgeCfg -> Double
hcC3 :: HedgeCfg -> Double
hcMargin :: HedgeCfg -> Maybe Double
hcSign :: Config
hcMagn1 :: Config
hcMagn2 :: Config
hcMagn3 :: Config
hcCdf :: Config
hcQs :: [Double]
hcMix :: Config
hcC1 :: Double
hcC2 :: Double
hcC3 :: Double
hcMargin :: Maybe Double
..} HedgeState{[State]
State
State
State
hsSign :: HedgeState -> State
hsMagn1 :: HedgeState -> State
hsMagn2 :: HedgeState -> State
hsMagn3 :: HedgeState -> State
hsCdf :: HedgeState -> [State]
hsMix :: HedgeState -> State
hsSign :: State
hsMagn1 :: State
hsMagn2 :: State
hsMagn3 :: State
hsCdf :: [State]
hsMix :: State
..} !Double
d !Double
ta !Double
tb =
  let !s' :: State
s'  = if Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0
             then State
hsSign
             else Config -> State -> Bool -> State
EPSign.update Config
hcSign State
hsSign (Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0)
      !m1' :: State
m1' = Config -> State -> Double -> State
EPMagn.update Config
hcMagn1 State
hsMagn1 (Double -> Double -> Double
clipD Double
hcC1 Double
d)
      !m2' :: State
m2' = Config -> State -> Double -> State
EPMagn.update Config
hcMagn2 State
hsMagn2 (Double -> Double -> Double
clipD Double
hcC2 Double
d)
      !m3' :: State
m3' = Config -> State -> Double -> State
EPMagn.update Config
hcMagn3 State
hsMagn3 (Double -> Double -> Double
clipD Double
hcC3 Double
d)
      !cd' :: [State]
cd' = Config -> [Double] -> [State] -> Double -> Double -> [State]
stepCdf Config
hcCdf [Double]
hcQs [State]
hsCdf Double
ta Double
tb
      -- under a margin only the magnitude components gate; the
      -- sign and CDF components are stepped above for their
      -- diagnostic peaks but stay out of the mixture.
      !evs :: [Double]
evs = case Maybe Double
hcMargin of
        Just Double
_  ->
          [ State -> Double
EPMagn.log_evalue State
m1'
          , State -> Double
EPMagn.log_evalue State
m2'
          , State -> Double
EPMagn.log_evalue State
m3'
          ]
        Maybe Double
Nothing ->
          ( State -> Double
EPSign.log_evalue State
s'
          Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: State -> Double
EPMagn.log_evalue State
m1'
          Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: State -> Double
EPMagn.log_evalue State
m2'
          Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: State -> Double
EPMagn.log_evalue State
m3'
          Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: (State -> Double) -> [State] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map State -> Double
EPMagn.log_evalue [State]
cd'
          )
      !x' :: State
x'  = Config -> State -> [Double] -> State
EPMix.update Config
hcMix State
hsMix [Double]
evs
  in  HedgeState
        { hsSign :: State
hsSign  = State
s'
        , hsMagn1 :: State
hsMagn1 = State
m1'
        , hsMagn2 :: State
hsMagn2 = State
m2'
        , hsMagn3 :: State
hsMagn3 = State
m3'
        , hsCdf :: [State]
hsCdf   = [State]
cd'
        , hsMix :: State
hsMix   = State
x'
        }

-- Step every CDF-indicator component. Spine- and element-strict so
-- the per-pair states don't accumulate thunks across the budget.
stepCdf
  :: EPMagn.Config -> [Double] -> [EPMagn.State] -> Double -> Double
  -> [EPMagn.State]
stepCdf :: Config -> [Double] -> [State] -> Double -> Double -> [State]
stepCdf !Config
cfg = [Double] -> [State] -> Double -> Double -> [State]
go
  where
    go :: [Double] -> [State] -> Double -> Double -> [State]
go (Double
q : [Double]
qs) (State
s : [State]
ss) !Double
ta !Double
tb =
      let !s' :: State
s'  = Config -> State -> Double -> State
EPMagn.update Config
cfg State
s (Double -> Double -> Double -> Double
cdfDiff Double
q Double
ta Double
tb)
          !ss' :: [State]
ss' = [Double] -> [State] -> Double -> Double -> [State]
go [Double]
qs [State]
ss Double
ta Double
tb
      in  State
s' State -> [State] -> [State]
forall a. a -> [a] -> [a]
: [State]
ss'
    go [Double]
_ [State]
_ Double
_ Double
_ = []

-- The antisymmetric indicator functional at cut point @q@:
-- @1[ta <= q] - 1[tb <= q]@, valued in @{-1, 0, 1}@, with
-- conditional mean @F_A(q) - F_B(q)@.
cdfDiff :: Double -> Double -> Double -> Double
cdfDiff :: Double -> Double -> Double -> Double
cdfDiff !Double
q !Double
ta !Double
tb = Double -> Double
forall {a}. Num a => Double -> a
ind Double
ta Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
forall {a}. Num a => Double -> a
ind Double
tb
  where
    ind :: Double -> a
ind !Double
t | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
q    = a
1
           | Bool
otherwise = a
0
{-# INLINE cdfDiff #-}

-- Pair each cut point with its component's peak log e-value. The
-- state list is aligned with 'hcQs' by construction, so the zip is
-- total on both.
cdfPeaks :: [Double] -> [EPMagn.State] -> [(Double, Double)]
cdfPeaks :: [Double] -> [State] -> [(Double, Double)]
cdfPeaks [Double]
qs = [Double] -> [Double] -> [(Double, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
qs ([Double] -> [(Double, Double)])
-> ([State] -> [Double]) -> [State] -> [(Double, Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State -> Double) -> [State] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map State -> Double
EPMagn.log_evalue_sup

clipD :: Double -> Double -> Double
clipD :: Double -> Double -> Double
clipD !Double
lim !Double
x
  | Double -> Double
forall a. Num a => a -> a
abs Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
lim = if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then Double
lim else Double -> Double
forall a. Num a => a -> a
negate Double
lim
  | Bool
otherwise   = Double
x
{-# INLINE clipD #-}

-- The effect-estimation grid: interior candidate means over
-- @[-16c, 16c]@ for the confidence sequence behind 'resEffect'.
-- 300 candidates resolve the interval endpoints to ~0.1c,
-- comparable to the shift scale the tight magnitude component can
-- detect; the per-pair update cost is O(live candidates), falls as
-- evidence rejects candidates, and sits outside the timed region
-- (and is order-symmetric), so measurement hygiene is unaffected.
effectGrid :: Int
effectGrid :: Int
effectGrid = Int
300

-- The order bit: splitmix64 from the resolved seed, carried as a
-- @Word64@ in @{0, 1}@ and consumed arithmetically, never by a case
-- (see 'runPair').

nextOrderBit :: Word64 -> (Word64, Word64)
nextOrderBit :: Word64 -> (Word64, Word64)
nextOrderBit !Word64
s =
  let (!Word64
s', !Word64
w) = Word64 -> (Word64, Word64)
splitMix Word64
s
  in  (Word64
s', Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
B..&. Word64
1)
{-# INLINE nextOrderBit #-}

-- Resolve the (root, warmup, main) seed triple: the root is the
-- user's seed or fresh OS entropy, reported as 'resSeed'; warmup and
-- main derive from it. Entropy rather than a clock reading, since a
-- periodic nuisance process may be periodic in that very clock; the
-- clock is only a fallback where @\/dev\/urandom@ is unreadable.
resolveSeeds :: Maybe Word64 -> IO (Word64, Word64, Word64)
resolveSeeds :: Maybe Word64 -> IO (Word64, Word64, Word64)
resolveSeeds Maybe Word64
mseed = do
  !base <- case Maybe Word64
mseed of
    Just Word64
s  -> Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
s
    Maybe Word64
Nothing -> do
      mw <- IO (Maybe Word64)
osEntropy
      case mw of
        Just Word64
w  -> Word64 -> IO Word64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
        Maybe Word64
Nothing -> IO Word64
getMonotonicTimeNSec
  let (!s1, !w1) = splitMix base
      (_ , !w2) = splitMix s1
  pure (base, w1, w2)

-- Eight bytes from /dev/urandom, big-endian. 'Nothing' on any IO
-- failure (absent device, sandbox, exhausted descriptors).
osEntropy :: IO (Maybe Word64)
osEntropy :: IO (Maybe Word64)
osEntropy = (Either IOException ByteString -> Maybe Word64)
-> IO (Either IOException ByteString) -> IO (Maybe Word64)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOException ByteString -> Maybe Word64
forall {a}. Num a => Either IOException ByteString -> Maybe a
toWord (IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IOMode -> (Handle -> IO ByteString) -> IO ByteString
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
urandom IOMode
ReadMode Handle -> IO ByteString
grab))
  where
    urandom :: String
urandom = String
"/dev/urandom"
    grab :: Handle -> IO ByteString
grab Handle
h  = Handle -> Int -> IO ByteString
BS.hGet Handle
h Int
8
    toWord :: Either IOException ByteString -> Maybe a
toWord (Left IOException
e)   = Maybe a -> IOException -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing (IOException
e :: IOException)
    toWord (Right ByteString
bs)
      | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$! (a -> Word8 -> a) -> a -> ByteString -> a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' a -> Word8 -> a
forall {a} {a}. (Integral a, Num a) => a -> a -> a
step a
0 ByteString
bs
      | Bool
otherwise         = Maybe a
forall a. Maybe a
Nothing
    step :: a -> a -> a
step !a
acc !a
w = a
acc a -> a -> a
forall a. Num a => a -> a -> a
* a
256 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w

-- Warmup: run @cfgWarmup@ randomly ordered pairs, returning each
-- pair's readings for 'channel' to calibrate from.
warmup :: Config -> (Word64 -> IO r) -> Word64 -> IO [r]
warmup :: forall r. Config -> (Word64 -> IO r) -> Word64 -> IO [r]
warmup Config
cfg Word64 -> IO r
pair = Int -> [r] -> Word64 -> IO [r]
go Int
0 []
  where
    go :: Int -> [r] -> Word64 -> IO [r]
go !Int
i ![r]
acc !Word64
rng
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Config -> Int
cfgWarmup Config
cfg = [r] -> IO [r]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [r]
acc
      | Bool
otherwise = do
          let (!Word64
rng', !Word64
bit) = Word64 -> (Word64, Word64)
nextOrderBit Word64
rng
          !r <- Word64 -> IO r
pair Word64
bit
          go (i + 1) (r : acc) rng'

-- Calibrate from warmup (A, B) readings, returning
-- @(c, qs, meterResolves, medReading)@:
--
--   * @c = max 1 (2 * p99(|d|))@, the clip bound; the floor keeps it
--     positive when a PMU meter on constant-time code reads zero
--     differences, which is fine (the run then passes at budget).
--   * @qs@, the CDF cut points: order statistics of the pooled
--     readings, identical for both classes (which keeps the
--     indicator antisymmetric), deduplicated so a discrete meter
--     does not inflate @K@.
--   * @meterResolves@, whether @p99@ of the readings is nonzero;
--     if not, the meter's quantum swallows the target and the caller
--     throws 'WarmupZeroDuration'.
--   * @medReading@, the pooled median, which resolves a relative
--     'cfgMargin'.
calibrate :: [(Double, Double)] -> (Double, [Double], Bool, Double)
calibrate :: [(Double, Double)] -> (Double, [Double], Bool, Double)
calibrate [(Double, Double)]
ws =
  let !readings :: [Double]
readings = [[Double]] -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Double
x, Double
y] | (Double
x, Double
y) <- [(Double, Double)]
ws ]
      !sortedR :: [Double]
sortedR  = [Double] -> [Double]
forall a. Ord a => [a] -> [a]
sort [Double]
readings
      !p99d :: Double
p99d     = [Double] -> Double
forall a. (Ord a, Num a) => [a] -> a
orderStat99 [ Double -> Double
forall a. Num a => a -> a
abs (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y) | (Double
x, Double
y) <- [(Double, Double)]
ws ]
      !p99r :: Double
p99r     = [Double] -> Double
forall a. (Ord a, Num a) => [a] -> a
orderStat99 [Double]
readings
      !qs :: [Double]
qs       = [Double] -> [Double]
cutPoints [Double]
sortedR
      !medR :: Double
medR     = Int -> [Double] -> Double
forall a. Num a => Int -> [a] -> a
nth ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
sortedR Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Double]
sortedR
  -- twice the order statistic leaves headroom for occasional
  -- outliers; larger differences are clipped in the main phase.
  in  (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
p99d), [Double]
qs, Double
p99r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0, Double
medR)

-- Empirical @~p99@ order statistic. Sorts and picks index
-- @(m * 99) \/ 100@; degenerates to the sample max at small @m@
-- (documented on 'cfgWarmup').
orderStat99 :: Ord a => Num a => [a] -> a
orderStat99 :: forall a. (Ord a, Num a) => [a] -> a
orderStat99 [a]
xs =
  let !sorted :: [a]
sorted = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
xs
  in  Int -> [a] -> a
forall a. Num a => Int -> [a] -> a
nth (([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
sorted Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
99) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100) [a]
sorted
{-# INLINE orderStat99 #-}

-- The levels at which the CDF-indicator components cut the pooled
-- warmup readings. Spread across the bulk rather than the tails:
-- a cut point out at the extremes leaves both indicators equal on
-- nearly every pair, contributing no evidence while still costing
-- its share of @log K@. The topmost level is deliberately below
-- the p99 that sets the clip bound, so the two calibrations do not
-- collapse onto the same statistic.
cdfLevels :: [Double]
cdfLevels :: [Double]
cdfLevels = [Double
0.10, Double
0.25, Double
0.50, Double
0.75, Double
0.90]

-- Nearest-rank order statistics of a sorted reading list at
-- 'cdfLevels', ascending and deduplicated. Empty when warmup
-- collected nothing.
cutPoints :: [Double] -> [Double]
cutPoints :: [Double] -> [Double]
cutPoints [Double]
sorted
  | Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0    = []
  | Bool
otherwise = [Double] -> [Double]
dedupAsc ((Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
forall {a}. RealFrac a => a -> Double
pick [Double]
cdfLevels)
  where
    !m :: Int
m = [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
sorted
    pick :: a -> Double
pick !a
p = Int -> [Double] -> Double
forall a. Num a => Int -> [a] -> a
nth (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (a
p a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)))) [Double]
sorted

-- Drop repeats from an ascending list.
dedupAsc :: [Double] -> [Double]
dedupAsc :: [Double] -> [Double]
dedupAsc (Double
x : Double
y : [Double]
rest)
  | Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
y    = [Double] -> [Double]
dedupAsc (Double
y Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
rest)
  | Bool
otherwise = Double
x Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double] -> [Double]
dedupAsc (Double
y Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
rest)
dedupAsc [Double]
xs = [Double]
xs